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