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