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