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