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