FS/FS/part_export/sqlradius.pm

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