FS/FS/part_export/sqlradius.pm

   1 package FS::part_export::sqlradius;
   2
   3 use vars qw(@ISA @EXPORT_OK $DEBUG %info %options $notes1 $notes2);
   4 use Exporter;
   5 use Tie::IxHash;
   6 use FS::Record qw( dbh qsearch qsearchs str2time_sql );
   7 use FS::part_export;
   8 use FS::svc_acct;
   9 use FS::export_svc;
  10 use Carp qw( cluck );
  11
  12 @ISA = qw(FS::part_export);
  13 @EXPORT_OK = qw( sqlradius_connect );
  14
  15 $DEBUG = 1;
  16
  17 my %groups;
  18 tie %options, 'Tie::IxHash',
  19   'datasrc'  => { label=>'DBI data source ' },
  20   'username' => { label=>'Database username' },
  21   'password' => { label=>'Database password' },
  22   'usergroup' => { label   => 'Group table',
  23                    type    => 'select',
  24                    options => [qw( usergroup radusergroup ) ],
  25                  },
  26   'ignore_accounting' => {
  27     type  => 'checkbox',
  28     label => 'Ignore accounting records from this database'
  29   },
  30   'process_single_realm' => {
  31     type  => 'checkbox',
  32     label => 'Only process one realm of accounting records',
  33   },
  34   'realm' => { label => 'The realm of of accounting records to be processed' },
  35   'ignore_long_sessions' => {
  36     type  => 'checkbox',
  37     label => 'Ignore sessions which span billing periods',
  38   },
  39   'hide_ip' => {
  40     type  => 'checkbox',
  41     label => 'Hide IP address information on session reports',
  42   },
  43   'hide_data' => {
  44     type  => 'checkbox',
  45     label => 'Hide download/upload information on session reports',
  46   },
  47   'show_called_station' => {
  48     type  => 'checkbox',
  49     label => 'Show the Called-Station-ID on session reports',
  50   },
  51   'overlimit_groups' => {
  52       label => 'Radius groups to assign to svc_acct which has exceeded its bandwidth or time limit (if not overridden by overlimit_groups global or per-agent config)',
  53       type  => 'select',
  54       multi => 1,
  55       option_label  => sub {
  56         $groups{$_[0]};
  57       },
  58       option_values => sub {
  59         %groups = (
  60               map { $_->groupnum, $_->long_description }
  61                   qsearch('radius_group', {}),
  62             );
  63             sort keys (%groups);
  64       },
  65    } ,
  66   'groups_susp_reason' => { label =>
  67                              'Radius group mapping to reason (via template user) (svcnum|username|username@domain  reasonnum|reason)',
  68                             type  => 'textarea',
  69                           },
  70
  71 ;
  72
  73 $notes1 = <<'END';
  74 Real-time export of <b>radcheck</b>, <b>radreply</b> and <b>usergroup</b>/<b>radusergroup</b>
  75 tables to any SQL database for
  76 <a href="http://www.freeradius.org/">FreeRADIUS</a>
  77 or <a href="http://radius.innercite.com/">ICRADIUS</a>.
  78 END
  79
  80 $notes2 = <<'END';
  81 An existing RADIUS database will be updated in realtime, but you can use
  82 <a href="http://www.freeside.biz/mediawiki/index.php/Freeside:1.9:Documentation:Developer/bin/freeside-sqlradius-reset">freeside-sqlradius-reset</a>
  83 to delete the entire RADIUS database and repopulate the tables from the
  84 Freeside database.  See the
  85 <a href="http://search.cpan.org/dist/DBI/DBI.pm#connect">DBI documentation</a>
  86 and the
  87 <a href="http://search.cpan.org/search?mode=module&query=DBD%3A%3A">documentation for your DBD</a>
  88 for the exact syntax of a DBI data source.
  89 <ul>
  90   <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.
  91   <li>Using ICRADIUS, add a dummy "op" column to your database:
  92     <blockquote><code>
  93       ALTER&nbsp;TABLE&nbsp;radcheck&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='<br>
  94       ALTER&nbsp;TABLE&nbsp;radreply&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='<br>
  95       ALTER&nbsp;TABLE&nbsp;radgroupcheck&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='<br>
  96       ALTER&nbsp;TABLE&nbsp;radgroupreply&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='
  97     </code></blockquote>
  98   <li>Using Radiator, see the
  99     <a href="http://www.open.com.au/radiator/faq.html#38">Radiator FAQ</a>
 100     for configuration information.
 101 </ul>
 102 END
 103
 104 %info = (
 105   'svc'      => 'svc_acct',
 106   'desc'     => 'Real-time export to SQL-backed RADIUS (FreeRADIUS, ICRADIUS)',
 107   'options'  => \%options,
 108   'nodomain' => 'Y',
 109   'nas'      => 'Y', # show export_nas selection in UI
 110   'notes'    => $notes1.
 111                 'This export does not export RADIUS realms (see also '.
 112                 'sqlradius_withdomain).  '.
 113                 $notes2
 114 );
 115
 116 sub _groups_susp_reason_map { map { reverse( /^\s*(\S+)\s*(.*)$/ ) }
 117                               split( "\n", shift->option('groups_susp_reason'));
 118 }
 119
 120 sub rebless { shift; }
 121
 122 sub export_username { # override for other svcdb
 123   my($self, $svc_acct) = (shift, shift);
 124   warn "export_username called on $self with arg $svc_acct" if $DEBUG > 1;
 125   $svc_acct->username;
 126 }
 127
 128 sub radius_reply { #override for other svcdb
 129   my($self, $svc_acct) = (shift, shift);
 130   $svc_acct->radius_reply;
 131 }
 132
 133 sub radius_check { #override for other svcdb
 134   my($self, $svc_acct) = (shift, shift);
 135   $svc_acct->radius_check;
 136 }
 137
 138 sub _export_insert {
 139   my($self, $svc_x) = (shift, shift);
 140
 141   foreach my $table (qw(reply check)) {
 142     my $method = "radius_$table";
 143     my %attrib = $self->$method($svc_x);
 144     next unless keys %attrib;
 145     my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'insert',
 146       $table, $self->export_username($svc_x), %attrib );
 147     return $err_or_queue unless ref($err_or_queue);
 148   }
 149   my @groups = $svc_x->radius_groups;
 150   if ( @groups ) {
 151     cluck localtime(). ": queuing usergroup_insert for ". $svc_x->svcnum.
 152           " (". $self->export_username($svc_x). " with ". join(", ", @groups)
 153       if $DEBUG;
 154     my $usergroup = $self->option('usergroup') || 'usergroup';
 155     my $err_or_queue = $self->sqlradius_queue(
 156       $svc_x->svcnum, 'usergroup_insert',
 157       $self->export_username($svc_x), $usergroup, @groups );
 158     return $err_or_queue unless ref($err_or_queue);
 159   }
 160   '';
 161 }
 162
 163 sub _export_replace {
 164   my( $self, $new, $old ) = (shift, shift, shift);
 165
 166   local $SIG{HUP} = 'IGNORE';
 167   local $SIG{INT} = 'IGNORE';
 168   local $SIG{QUIT} = 'IGNORE';
 169   local $SIG{TERM} = 'IGNORE';
 170   local $SIG{TSTP} = 'IGNORE';
 171   local $SIG{PIPE} = 'IGNORE';
 172
 173   my $oldAutoCommit = $FS::UID::AutoCommit;
 174   local $FS::UID::AutoCommit = 0;
 175   my $dbh = dbh;
 176
 177   my $jobnum = '';
 178   if ( $self->export_username($old) ne $self->export_username($new) ) {
 179     my $usergroup = $self->option('usergroup') || 'usergroup';
 180     my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'rename',
 181       $self->export_username($new), $self->export_username($old), $usergroup );
 182     unless ( ref($err_or_queue) ) {
 183       $dbh->rollback if $oldAutoCommit;
 184       return $err_or_queue;
 185     }
 186     $jobnum = $err_or_queue->jobnum;
 187   }
 188
 189   foreach my $table (qw(reply check)) {
 190     my $method = "radius_$table";
 191     my %new = $new->$method();
 192     my %old = $old->$method();
 193     if ( grep { !exists $old{$_} #new attributes
 194                 || $new{$_} ne $old{$_} #changed
 195               } keys %new
 196     ) {
 197       my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
 198         $table, $self->export_username($new), %new );
 199       unless ( ref($err_or_queue) ) {
 200         $dbh->rollback if $oldAutoCommit;
 201         return $err_or_queue;
 202       }
 203       if ( $jobnum ) {
 204         my $error = $err_or_queue->depend_insert( $jobnum );
 205         if ( $error ) {
 206           $dbh->rollback if $oldAutoCommit;
 207           return $error;
 208         }
 209       }
 210     }
 211
 212     my @del = grep { !exists $new{$_} } keys %old;
 213     if ( @del ) {
 214       my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'attrib_delete',
 215         $table, $self->export_username($new), @del );
 216       unless ( ref($err_or_queue) ) {
 217         $dbh->rollback if $oldAutoCommit;
 218         return $err_or_queue;
 219       }
 220       if ( $jobnum ) {
 221         my $error = $err_or_queue->depend_insert( $jobnum );
 222         if ( $error ) {
 223           $dbh->rollback if $oldAutoCommit;
 224           return $error;
 225         }
 226       }
 227     }
 228   }
 229
 230   my $error;
 231   my (@oldgroups) = $old->radius_groups;
 232   my (@newgroups) = $new->radius_groups;
 233   $error = $self->sqlreplace_usergroups( $new->svcnum,
 234                                          $self->export_username($new),
 235                                          $jobnum ? $jobnum : '',
 236                                          \@oldgroups,
 237                                          \@newgroups,
 238                                        );
 239   if ( $error ) {
 240     $dbh->rollback if $oldAutoCommit;
 241     return $error;
 242   }
 243
 244   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 245
 246   '';
 247 }
 248
 249 sub _export_suspend {
 250   my( $self, $svc_acct ) = (shift, shift);
 251
 252   my $new = $svc_acct->clone_suspended;
 253
 254   local $SIG{HUP} = 'IGNORE';
 255   local $SIG{INT} = 'IGNORE';
 256   local $SIG{QUIT} = 'IGNORE';
 257   local $SIG{TERM} = 'IGNORE';
 258   local $SIG{TSTP} = 'IGNORE';
 259   local $SIG{PIPE} = 'IGNORE';
 260
 261   my $oldAutoCommit = $FS::UID::AutoCommit;
 262   local $FS::UID::AutoCommit = 0;
 263   my $dbh = dbh;
 264
 265   my @newgroups = $self->suspended_usergroups($svc_acct);
 266
 267   unless (@newgroups) { #don't change password if assigning to a suspended group
 268
 269     my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
 270       'check', $self->export_username($new), $new->radius_check );
 271     unless ( ref($err_or_queue) ) {
 272       $dbh->rollback if $oldAutoCommit;
 273       return $err_or_queue;
 274     }
 275
 276   }
 277
 278   my $error =
 279     $self->sqlreplace_usergroups( $new->svcnum,
 280                                   $self->export_username($new),
 281                                   '',
 282                                   [ $svc_acct->radius_groups ],
 283                                   \@newgroups,
 284                                 );
 285   if ( $error ) {
 286     $dbh->rollback if $oldAutoCommit;
 287     return $error;
 288   }
 289   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 290
 291   '';
 292 }
 293
 294 sub _export_unsuspend {
 295   my( $self, $svc_acct ) = (shift, shift);
 296
 297   local $SIG{HUP} = 'IGNORE';
 298   local $SIG{INT} = 'IGNORE';
 299   local $SIG{QUIT} = 'IGNORE';
 300   local $SIG{TERM} = 'IGNORE';
 301   local $SIG{TSTP} = 'IGNORE';
 302   local $SIG{PIPE} = 'IGNORE';
 303
 304   my $oldAutoCommit = $FS::UID::AutoCommit;
 305   local $FS::UID::AutoCommit = 0;
 306   my $dbh = dbh;
 307
 308   my $err_or_queue = $self->sqlradius_queue( $svc_acct->svcnum, 'insert',
 309     'check', $self->export_username($svc_acct), $svc_acct->radius_check );
 310   unless ( ref($err_or_queue) ) {
 311     $dbh->rollback if $oldAutoCommit;
 312     return $err_or_queue;
 313   }
 314
 315   my $error;
 316   my (@oldgroups) = $self->suspended_usergroups($svc_acct);
 317   $error = $self->sqlreplace_usergroups( $svc_acct->svcnum,
 318                                          $self->export_username($svc_acct),
 319                                          '',
 320                                          \@oldgroups,
 321                                          [ $svc_acct->radius_groups ],
 322                                        );
 323   if ( $error ) {
 324     $dbh->rollback if $oldAutoCommit;
 325     return $error;
 326   }
 327   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 328
 329   '';
 330 }
 331
 332 sub _export_delete {
 333   my( $self, $svc_x ) = (shift, shift);
 334   my $usergroup = $self->option('usergroup') || 'usergroup';
 335   my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'delete',
 336     $self->export_username($svc_x), $usergroup );
 337   ref($err_or_queue) ? '' : $err_or_queue;
 338 }
 339
 340 sub sqlradius_queue {
 341   my( $self, $svcnum, $method ) = (shift, shift, shift);
 342   my $queue = new FS::queue {
 343     'svcnum' => $svcnum,
 344     'job'    => "FS::part_export::sqlradius::sqlradius_$method",
 345   };
 346   $queue->insert(
 347     $self->option('datasrc'),
 348     $self->option('username'),
 349     $self->option('password'),
 350     @_,
 351   ) or $queue;
 352 }
 353
 354 sub suspended_usergroups {
 355   my ($self, $svc_acct) = (shift, shift);
 356
 357   return () unless $svc_acct;
 358
 359   #false laziness with FS::part_export::shellcommands
 360   #subclass part_export?
 361
 362   my $r = $svc_acct->cust_svc->cust_pkg->last_reason('susp');
 363   my %reasonmap = $self->_groups_susp_reason_map;
 364   my $userspec = '';
 365   if ($r) {
 366     $userspec = $reasonmap{$r->reasonnum}
 367       if exists($reasonmap{$r->reasonnum});
 368     $userspec = $reasonmap{$r->reason}
 369       if (!$userspec && exists($reasonmap{$r->reason}));
 370   }
 371   my $suspend_user;
 372   if ($userspec =~ /^\d+$/ ){
 373     $suspend_user = qsearchs( 'svc_acct', { 'svcnum' => $userspec } );
 374   }elsif ($userspec =~ /^\S+\@\S+$/){
 375     my ($username,$domain) = split(/\@/, $userspec);
 376     for my $user (qsearch( 'svc_acct', { 'username' => $username } )){
 377       $suspend_user = $user if $userspec eq $user->email;
 378     }
 379   }elsif ($userspec){
 380     $suspend_user = qsearchs( 'svc_acct', { 'username' => $userspec } );
 381   }
 382   #esalf
 383   return $suspend_user->radius_groups if $suspend_user;
 384   ();
 385 }
 386
 387 sub sqlradius_insert { #subroutine, not method
 388   my $dbh = sqlradius_connect(shift, shift, shift);
 389   my( $table, $username, %attributes ) = @_;
 390
 391   foreach my $attribute ( keys %attributes ) {
 392
 393     my $s_sth = $dbh->prepare(
 394       "SELECT COUNT(*) FROM rad$table WHERE UserName = ? AND Attribute = ?"
 395     ) or die $dbh->errstr;
 396     $s_sth->execute( $username, $attribute ) or die $s_sth->errstr;
 397
 398     if ( $s_sth->fetchrow_arrayref->[0] ) {
 399
 400       my $u_sth = $dbh->prepare(
 401         "UPDATE rad$table SET Value = ? WHERE UserName = ? AND Attribute = ?"
 402       ) or die $dbh->errstr;
 403       $u_sth->execute($attributes{$attribute}, $username, $attribute)
 404         or die $u_sth->errstr;
 405
 406     } else {
 407
 408       my $i_sth = $dbh->prepare(
 409         "INSERT INTO rad$table ( UserName, Attribute, op, Value ) ".
 410           "VALUES ( ?, ?, ?, ? )"
 411       ) or die $dbh->errstr;
 412       $i_sth->execute(
 413         $username,
 414         $attribute,
 415         ( $attribute eq 'Password' ? '==' : ':=' ),
 416         $attributes{$attribute},
 417       ) or die $i_sth->errstr;
 418
 419     }
 420
 421   }
 422   $dbh->disconnect;
 423 }
 424
 425 sub sqlradius_usergroup_insert { #subroutine, not method
 426   my $dbh = sqlradius_connect(shift, shift, shift);
 427   my $username = shift;
 428   my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
 429   my @groups = @_;
 430
 431   my $s_sth = $dbh->prepare(
 432     "SELECT COUNT(*) FROM $usergroup WHERE UserName = ? AND GroupName = ?"
 433   ) or die $dbh->errstr;
 434
 435   my $sth = $dbh->prepare(
 436     "INSERT INTO $usergroup ( UserName, GroupName ) VALUES ( ?, ? )"
 437   ) or die $dbh->errstr;
 438
 439   foreach my $group ( @groups ) {
 440     $s_sth->execute( $username, $group ) or die $s_sth->errstr;
 441     if ($s_sth->fetchrow_arrayref->[0]) {
 442       warn localtime() . ": sqlradius_usergroup_insert attempted to reinsert " .
 443            "$group for $username\n"
 444         if $DEBUG;
 445       next;
 446     }
 447     $sth->execute( $username, $group )
 448       or die "can't insert into groupname table: ". $sth->errstr;
 449   }
 450   if ( $s_sth->{Active} ) {
 451     warn "sqlradius s_sth still active; calling ->finish()";
 452     $s_sth->finish;
 453   }
 454   if ( $sth->{Active} ) {
 455     warn "sqlradius sth still active; calling ->finish()";
 456     $sth->finish;
 457   }
 458   $dbh->disconnect;
 459 }
 460
 461 sub sqlradius_usergroup_delete { #subroutine, not method
 462   my $dbh = sqlradius_connect(shift, shift, shift);
 463   my $username = shift;
 464   my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
 465   my @groups = @_;
 466
 467   my $sth = $dbh->prepare(
 468     "DELETE FROM $usergroup WHERE UserName = ? AND GroupName = ?"
 469   ) or die $dbh->errstr;
 470   foreach my $group ( @groups ) {
 471     $sth->execute( $username, $group )
 472       or die "can't delete from groupname table: ". $sth->errstr;
 473   }
 474   $dbh->disconnect;
 475 }
 476
 477 sub sqlradius_rename { #subroutine, not method
 478   my $dbh = sqlradius_connect(shift, shift, shift);
 479   my($new_username, $old_username) = (shift, shift);
 480   my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
 481   foreach my $table (qw(radreply radcheck), $usergroup ) {
 482     my $sth = $dbh->prepare("UPDATE $table SET Username = ? WHERE UserName = ?")
 483       or die $dbh->errstr;
 484     $sth->execute($new_username, $old_username)
 485       or die "can't update $table: ". $sth->errstr;
 486   }
 487   $dbh->disconnect;
 488 }
 489
 490 sub sqlradius_attrib_delete { #subroutine, not method
 491   my $dbh = sqlradius_connect(shift, shift, shift);
 492   my( $table, $username, @attrib ) = @_;
 493
 494   foreach my $attribute ( @attrib ) {
 495     my $sth = $dbh->prepare(
 496         "DELETE FROM rad$table WHERE UserName = ? AND Attribute = ?" )
 497       or die $dbh->errstr;
 498     $sth->execute($username,$attribute)
 499       or die "can't delete from rad$table table: ". $sth->errstr;
 500   }
 501   $dbh->disconnect;
 502 }
 503
 504 sub sqlradius_delete { #subroutine, not method
 505   my $dbh = sqlradius_connect(shift, shift, shift);
 506   my $username = shift;
 507   my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
 508
 509   foreach my $table (qw( radcheck radreply), $usergroup ) {
 510     my $sth = $dbh->prepare( "DELETE FROM $table WHERE UserName = ?" );
 511     $sth->execute($username)
 512       or die "can't delete from $table table: ". $sth->errstr;
 513   }
 514   $dbh->disconnect;
 515 }
 516
 517 sub sqlradius_connect {
 518   #my($datasrc, $username, $password) = @_;
 519   #DBI->connect($datasrc, $username, $password) or die $DBI::errstr;
 520   DBI->connect(@_) or die $DBI::errstr;
 521 }
 522
 523 sub sqlreplace_usergroups {
 524   my ($self, $svcnum, $username, $jobnum, $old, $new) = @_;
 525
 526   # (sorta) false laziness with FS::svc_acct::replace
 527   my @oldgroups = @$old;
 528   my @newgroups = @$new;
 529   my @delgroups = ();
 530   foreach my $oldgroup ( @oldgroups ) {
 531     if ( grep { $oldgroup eq $_ } @newgroups ) {
 532       @newgroups = grep { $oldgroup ne $_ } @newgroups;
 533       next;
 534     }
 535     push @delgroups, $oldgroup;
 536   }
 537
 538   my $usergroup = $self->option('usergroup') || 'usergroup';
 539
 540   if ( @delgroups ) {
 541     my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_delete',
 542       $username, $usergroup, @delgroups );
 543     return $err_or_queue
 544       unless ref($err_or_queue);
 545     if ( $jobnum ) {
 546       my $error = $err_or_queue->depend_insert( $jobnum );
 547       return $error if $error;
 548     }
 549   }
 550
 551   if ( @newgroups ) {
 552     cluck localtime(). ": queuing usergroup_insert for $svcnum ($username) ".
 553           "with ".  join(", ", @newgroups)
 554       if $DEBUG;
 555     my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_insert',
 556       $username, $usergroup, @newgroups );
 557     return $err_or_queue
 558       unless ref($err_or_queue);
 559     if ( $jobnum ) {
 560       my $error = $err_or_queue->depend_insert( $jobnum );
 561       return $error if $error;
 562     }
 563   }
 564   '';
 565 }
 566
 567
 568 #--
 569
 570 =item usage_sessions HASHREF
 571
 572 =item usage_sessions TIMESTAMP_START TIMESTAMP_END [ SVC_ACCT [ IP [ PREFIX [ SQL_SELECT ] ] ] ]
 573
 574 New-style: pass a hashref with the following keys:
 575
 576 =over 4
 577
 578 =item stoptime_start - Lower bound for AcctStopTime, as a UNIX timestamp
 579
 580 =item stoptime_end - Upper bound for AcctStopTime, as a UNIX timestamp
 581
 582 =item open_sessions - Only show records with no AcctStopTime (typically used without stoptime_* options and with starttime_* options instead)
 583
 584 =item starttime_start - Lower bound for AcctStartTime, as a UNIX timestamp
 585
 586 =item starttime_end - Upper bound for AcctStartTime, as a UNIX timestamp
 587
 588 =item svc_acct
 589
 590 =item ip
 591
 592 =item prefix
 593
 594 =back
 595
 596 Old-style:
 597
 598 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 599 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 600 functions.
 601
 602 SVC_ACCT, if specified, limits the results to the specified account.
 603
 604 IP, if specified, limits the results to the specified IP address.
 605
 606 PREFIX, if specified, limits the results to records with a matching
 607 Called-Station-ID.
 608
 609 #SQL_SELECT defaults to * if unspecified.  It can be useful to set it to
 610 #SUM(acctsessiontime) or SUM(AcctInputOctets), etc.
 611
 612 Returns an arrayref of hashrefs with the following fields:
 613
 614 =over 4
 615
 616 =item username
 617
 618 =item framedipaddress
 619
 620 =item acctstarttime
 621
 622 =item acctstoptime
 623
 624 =item acctsessiontime
 625
 626 =item acctinputoctets
 627
 628 =item acctoutputoctets
 629
 630 =item calledstationid
 631
 632 =back
 633
 634 =cut
 635
 636 #some false laziness w/cust_svc::seconds_since_sqlradacct
 637
 638 sub usage_sessions {
 639   my( $self ) = shift;
 640
 641   my $opt = {};
 642   my($start, $end, $svc_acct, $ip, $prefix) = ( '', '', '', '', '');
 643   my $summarize = 0;
 644   if ( ref($_[0]) ) {
 645     $opt = shift;
 646     $start    = $opt->{stoptime_start};
 647     $end      = $opt->{stoptime_end};
 648     $svc_acct = $opt->{svc_acct};
 649     $ip       = $opt->{ip};
 650     $prefix   = $opt->{prefix};
 651     $summarize   = $opt->{summarize};
 652   } else {
 653     ( $start, $end ) = splice(@_, 0, 2);
 654     $svc_acct = @_ ? shift : '';
 655     $ip = @_ ? shift : '';
 656     $prefix = @_ ? shift : '';
 657     #my $select = @_ ? shift : '*';
 658   }
 659
 660   $end ||= 2147483647;
 661
 662   return [] if $self->option('ignore_accounting');
 663
 664   my $dbh = sqlradius_connect( map $self->option($_),
 665                                    qw( datasrc username password ) );
 666
 667   #select a unix time conversion function based on database type
 668   my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
 669
 670   my @fields = (
 671                  qw( username realm framedipaddress
 672                      acctsessiontime acctinputoctets acctoutputoctets
 673                      calledstationid
 674                    ),
 675                  "$str2time acctstarttime ) as acctstarttime",
 676                  "$str2time acctstoptime ) as acctstoptime",
 677                );
 678
 679   @fields = ( 'username', 'sum(acctsessiontime) as acctsessiontime', 'sum(acctinputoctets) as acctinputoctets',
 680               'sum(acctoutputoctets) as acctoutputoctets',
 681             ) if $summarize;
 682
 683   my @param = ();
 684   my @where = ();
 685
 686   if ( $svc_acct ) {
 687     my $username = $self->export_username($svc_acct);
 688     if ( $username =~ /^([^@]+)\@([^@]+)$/ ) {
 689       push @where, '( UserName = ? OR ( UserName = ? AND Realm = ? ) )';
 690       push @param, $username, $1, $2;
 691     } else {
 692       push @where, 'UserName = ?';
 693       push @param, $username;
 694     }
 695   }
 696
 697   if ($self->option('process_single_realm')) {
 698     push @where, 'Realm = ?';
 699     push @param, $self->option('realm');
 700   }
 701
 702   if ( length($ip) ) {
 703     push @where, ' FramedIPAddress = ?';
 704     push @param, $ip;
 705   }
 706
 707   if ( length($prefix) ) {
 708     #assume sip: for now, else things get ugly trying to match /^\w+:$prefix/
 709     push @where, " CalledStationID LIKE 'sip:$prefix\%'";
 710   }
 711
 712   if ( $start ) {
 713     push @where, "$str2time AcctStopTime ) >= ?";
 714     push @param, $start;
 715   }
 716   if ( $end ) {
 717     push @where, "$str2time AcctStopTime ) <= ?";
 718     push @param, $end;
 719   }
 720   if ( $opt->{open_sessions} ) {
 721     push @where, 'AcctStopTime IS NULL';
 722   }
 723   if ( $opt->{starttime_start} ) {
 724     push @where, "$str2time AcctStartTime ) >= ?";
 725     push @param, $opt->{starttime_start};
 726   }
 727   if ( $opt->{starttime_end} ) {
 728     push @where, "$str2time AcctStartTime ) <= ?";
 729     push @param, $opt->{starttime_end};
 730   }
 731
 732   my $where = join(' AND ', @where);
 733   $where = "WHERE $where" if $where;
 734
 735   my $groupby = '';
 736   $groupby = 'GROUP BY username' if $summarize;
 737
 738   my $orderby = 'ORDER BY AcctStartTime DESC';
 739   $orderby = '' if $summarize;
 740
 741   my $sth = $dbh->prepare('SELECT '. join(', ', @fields).
 742                           "  FROM radacct $where $groupby $orderby
 743                         ") or die $dbh->errstr;
 744   $sth->execute(@param) or die $sth->errstr;
 745
 746   [ map { { %$_ } } @{ $sth->fetchall_arrayref({}) } ];
 747
 748 }
 749
 750 =item update_svc_acct
 751
 752 =cut
 753
 754 sub update_svc {
 755   my $self = shift;
 756
 757   my $conf = new FS::Conf;
 758
 759   my $fdbh = dbh;
 760   my $dbh = sqlradius_connect( map $self->option($_),
 761                                    qw( datasrc username password ) );
 762
 763   my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
 764   my @fields = qw( radacctid username realm acctsessiontime );
 765
 766   my @param = ();
 767   my $where = '';
 768
 769   my $sth = $dbh->prepare("
 770     SELECT RadAcctId, UserName, Realm, AcctSessionTime,
 771            $str2time AcctStartTime),  $str2time AcctStopTime),
 772            AcctInputOctets, AcctOutputOctets
 773       FROM radacct
 774       WHERE FreesideStatus IS NULL
 775         AND AcctStopTime IS NOT NULL
 776   ") or die $dbh->errstr;
 777   $sth->execute() or die $sth->errstr;
 778
 779   while ( my $row = $sth->fetchrow_arrayref ) {
 780     my($RadAcctId, $UserName, $Realm, $AcctSessionTime, $AcctStartTime,
 781        $AcctStopTime, $AcctInputOctets, $AcctOutputOctets) = @$row;
 782     warn "processing record: ".
 783          "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s"
 784       if $DEBUG;
 785
 786     $UserName = lc($UserName) unless $conf->exists('username-uppercase');
 787
 788     #my %search = ( 'username' => $UserName );
 789
 790     my $extra_sql = '';
 791     if ( ref($self) =~ /withdomain/ ) { #well...
 792       $extra_sql = " AND '$Realm' = ( SELECT domain FROM svc_domain
 793                           WHERE svc_domain.svcnum = svc_acct.domsvc ) ";
 794     }
 795
 796     my $oldAutoCommit = $FS::UID::AutoCommit; # can't undo side effects, but at
 797     local $FS::UID::AutoCommit = 0;           # least we can avoid over counting
 798
 799     my $status = 'skipped';
 800     my $errinfo = "for RADIUS detail RadAcctID $RadAcctId ".
 801                   "(UserName $UserName, Realm $Realm)";
 802
 803     if (    $self->option('process_single_realm')
 804          && $self->option('realm') ne $Realm )
 805     {
 806       warn "WARNING: wrong realm $errinfo - skipping\n" if $DEBUG;
 807     } else {
 808       my @svc_acct =
 809         grep { qsearch( 'export_svc', { 'exportnum' => $self->exportnum,
 810                                         'svcpart'   => $_->cust_svc->svcpart, } )
 811              }
 812         qsearch( 'svc_acct',
 813                    { 'username' => $UserName },
 814                    '',
 815                    $extra_sql
 816                  );
 817
 818       if ( !@svc_acct ) {
 819         warn "WARNING: no svc_acct record found $errinfo - skipping\n";
 820       } elsif ( scalar(@svc_acct) > 1 ) {
 821         warn "WARNING: multiple svc_acct records found $errinfo - skipping\n";
 822       } else {
 823
 824         my $svc_acct = $svc_acct[0];
 825         warn "found svc_acct ". $svc_acct->svcnum. " $errinfo\n" if $DEBUG;
 826
 827         $svc_acct->last_login($AcctStartTime);
 828         $svc_acct->last_logout($AcctStopTime);
 829
 830         my $session_time = $AcctStopTime;
 831         $session_time = $AcctStartTime if $self->option('ignore_long_sessions');
 832
 833         my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
 834         if ( $cust_pkg && $session_time < (    $cust_pkg->last_bill
 835                                             || $cust_pkg->setup     )  ) {
 836           $status = 'skipped (too old)';
 837         } else {
 838           my @st;
 839           push @st, _try_decrement($svc_acct, 'seconds',    $AcctSessionTime);
 840           push @st, _try_decrement($svc_acct, 'upbytes',    $AcctInputOctets);
 841           push @st, _try_decrement($svc_acct, 'downbytes',  $AcctOutputOctets);
 842           push @st, _try_decrement($svc_acct, 'totalbytes', $AcctInputOctets
 843                                                           + $AcctOutputOctets);
 844           $status=join(' ', @st);
 845         }
 846       }
 847     }
 848
 849     warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG;
 850     my $psth = $dbh->prepare("UPDATE radacct
 851                                 SET FreesideStatus = ?
 852                                 WHERE RadAcctId = ?"
 853     ) or die $dbh->errstr;
 854     $psth->execute($status, $RadAcctId) or die $psth->errstr;
 855
 856     $fdbh->commit or die $fdbh->errstr if $oldAutoCommit;
 857
 858   }
 859
 860 }
 861
 862 sub _try_decrement {
 863   my ($svc_acct, $column, $amount) = @_;
 864   if ( $svc_acct->$column !~ /^$/ ) {
 865     warn "  svc_acct.$column found (". $svc_acct->$column.
 866          ") - decrementing\n"
 867       if $DEBUG;
 868     my $method = 'decrement_' . $column;
 869     my $error = $svc_acct->$method($amount);
 870     die $error if $error;
 871     return 'done';
 872   } else {
 873     warn "  no existing $column value for svc_acct - skipping\n" if $DEBUG;
 874   }
 875   return 'skipped';
 876 }
 877
 878 =item export_nas_insert NAS
 879
 880 =item export_nas_delete NAS
 881
 882 =item export_nas_replace NEW_NAS OLD_NAS
 883
 884 Update the NAS table (allowed RADIUS clients) on the attached RADIUS
 885 server.  Currently requires the table to be named 'nas' and to follow
 886 the stock schema (/etc/freeradius/nas.sql).
 887
 888 =cut
 889
 890 sub export_nas_insert {  shift->export_nas_action('insert', @_); }
 891 sub export_nas_delete {  shift->export_nas_action('delete', @_); }
 892 sub export_nas_replace { shift->export_nas_action('replace', @_); }
 893
 894 sub export_nas_action {
 895   my $self = shift;
 896   my ($action, $new, $old) = @_;
 897   # find the NAS in the target table by its name
 898   my $nasname = ($action eq 'replace') ? $old->nasname : $new->nasname;
 899   my $nasnum = $new->nasnum;
 900
 901   my $err_or_queue = $self->sqlradius_queue('', "nas_$action",
 902     nasname => $nasname,
 903     nasnum => $nasnum
 904   );
 905   return $err_or_queue unless ref $err_or_queue;
 906   '';
 907 }
 908
 909 sub sqlradius_nas_insert {
 910   my $dbh = sqlradius_connect(shift, shift, shift);
 911   my %opt = @_;
 912   my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
 913     or die "nasnum ".$opt{'nasnum'}.' not found';
 914   # insert actual NULLs where FS::Record has translated to empty strings
 915   my @values = map { length($nas->$_) ? $nas->$_ : undef }
 916     qw( nasname shortname type secret server community description );
 917   my $sth = $dbh->prepare('INSERT INTO nas
 918 (nasname, shortname, type, secret, server, community, description)
 919 VALUES (?, ?, ?, ?, ?, ?, ?)');
 920   $sth->execute(@values) or die $dbh->errstr;
 921 }
 922
 923 sub sqlradius_nas_delete {
 924   my $dbh = sqlradius_connect(shift, shift, shift);
 925   my %opt = @_;
 926   my $sth = $dbh->prepare('DELETE FROM nas WHERE nasname = ?');
 927   $sth->execute($opt{'nasname'}) or die $dbh->errstr;
 928 }
 929
 930 sub sqlradius_nas_replace {
 931   my $dbh = sqlradius_connect(shift, shift, shift);
 932   my %opt = @_;
 933   my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
 934     or die "nasnum ".$opt{'nasnum'}.' not found';
 935   my @values = map {$nas->$_}
 936     qw( nasname shortname type secret server community description );
 937   my $sth = $dbh->prepare('UPDATE nas SET
 938     nasname = ?, shortname = ?, type = ?, secret = ?,
 939     server = ?, community = ?, description = ?
 940     WHERE nasname = ?');
 941   $sth->execute(@values, $opt{'nasname'}) or die $dbh->errstr;
 942 }
 943
 944 ###
 945 #class methods
 946 ###
 947
 948 sub all_sqlradius {
 949   #my $class = shift;
 950
 951   #don't just look for ->can('usage_sessions'), we're sqlradius-specific
 952   # (radiator is supposed to be setup with a radacct table)
 953   #i suppose it would be more slick to look for things that inherit from us..
 954
 955   my @part_export = ();
 956   push @part_export, qsearch('part_export', { 'exporttype' => $_ } )
 957     foreach qw( sqlradius sqlradius_withdomain radiator phone_sqlradius );
 958   @part_export;
 959 }
 960
 961 sub all_sqlradius_withaccounting {
 962   my $class = shift;
 963   grep { ! $_->option('ignore_accounting') } $class->all_sqlradius;
 964 }
 965
 966 1;
 967