FS/FS/part_export/sqlradius.pm

   1 package FS::part_export::sqlradius;
   2
   3 use strict;
   4 use vars qw(@ISA @EXPORT_OK $DEBUG %info %options $notes1 $notes2);
   5 use Exporter;
   6 use Tie::IxHash;
   7 use FS::Record qw( dbh qsearch qsearchs str2time_sql str2time_sql_closing );
   8 use FS::part_export;
   9 use FS::svc_acct;
  10 use FS::export_svc;
  11 use Carp qw( carp 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
 493   if ( $FS::svc_Common::noexport_hack ) {
 494     carp 'sqlradius_insert() suppressed by noexport_hack' if $DEBUG;
 495     return;
 496   }
 497
 498   my $dbh = sqlradius_connect(shift, shift, shift);
 499   my( $table, $username, %attributes ) = @_;
 500
 501   foreach my $attribute ( keys %attributes ) {
 502
 503     my $s_sth = $dbh->prepare(
 504       "SELECT COUNT(*) FROM rad$table WHERE UserName = ? AND Attribute = ?"
 505     ) or die $dbh->errstr;
 506     $s_sth->execute( $username, $attribute ) or die $s_sth->errstr;
 507
 508     if ( $s_sth->fetchrow_arrayref->[0] ) {
 509
 510       my $u_sth = $dbh->prepare(
 511         "UPDATE rad$table SET Value = ? WHERE UserName = ? AND Attribute = ?"
 512       ) or die $dbh->errstr;
 513       $u_sth->execute($attributes{$attribute}, $username, $attribute)
 514         or die $u_sth->errstr;
 515
 516     } else {
 517
 518       my $i_sth = $dbh->prepare(
 519         "INSERT INTO rad$table ( UserName, Attribute, op, Value ) ".
 520           "VALUES ( ?, ?, ?, ? )"
 521       ) or die $dbh->errstr;
 522       $i_sth->execute(
 523         $username,
 524         $attribute,
 525         ( $attribute eq 'Password' ? '==' : ':=' ),
 526         $attributes{$attribute},
 527       ) or die $i_sth->errstr;
 528
 529     }
 530
 531   }
 532   $dbh->disconnect;
 533 }
 534
 535 sub sqlradius_usergroup_insert { #subroutine, not method
 536
 537   if ( $FS::svc_Common::noexport_hack ) {
 538     carp 'sqlradius_usergroup_insert() suppressed by noexport_hack' if $DEBUG;
 539     return;
 540   }
 541
 542   my $dbh = sqlradius_connect(shift, shift, shift);
 543   my $username = shift;
 544   my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
 545   my @groups = @_;
 546
 547   my $s_sth = $dbh->prepare(
 548     "SELECT COUNT(*) FROM $usergroup WHERE UserName = ? AND GroupName = ?"
 549   ) or die $dbh->errstr;
 550
 551   my $sth = $dbh->prepare(
 552     "INSERT INTO $usergroup ( UserName, GroupName, Priority ) VALUES ( ?, ?, ? )"
 553   ) or die $dbh->errstr;
 554
 555   foreach ( @groups ) {
 556     my $group = $_->{'groupname'};
 557     my $priority = $_->{'priority'};
 558     $s_sth->execute( $username, $group ) or die $s_sth->errstr;
 559     if ($s_sth->fetchrow_arrayref->[0]) {
 560       warn localtime() . ": sqlradius_usergroup_insert attempted to reinsert " .
 561            "$group for $username\n"
 562         if $DEBUG;
 563       next;
 564     }
 565     $sth->execute( $username, $group, $priority )
 566       or die "can't insert into groupname table: ". $sth->errstr;
 567   }
 568   if ( $s_sth->{Active} ) {
 569     warn "sqlradius s_sth still active; calling ->finish()";
 570     $s_sth->finish;
 571   }
 572   if ( $sth->{Active} ) {
 573     warn "sqlradius sth still active; calling ->finish()";
 574     $sth->finish;
 575   }
 576   $dbh->disconnect;
 577 }
 578
 579 sub sqlradius_usergroup_delete { #subroutine, not method
 580
 581   if ( $FS::svc_Common::noexport_hack ) {
 582     carp 'sqlradius_usergroup_delete() suppressed by noexport_hack' if $DEBUG;
 583     return;
 584   }
 585
 586   my $dbh = sqlradius_connect(shift, shift, shift);
 587   my $username = shift;
 588   my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
 589   my @groups = @_;
 590
 591   my $sth = $dbh->prepare(
 592     "DELETE FROM $usergroup WHERE UserName = ? AND GroupName = ?"
 593   ) or die $dbh->errstr;
 594   foreach ( @groups ) {
 595     my $group = $_->{'groupname'};
 596     $sth->execute( $username, $group )
 597       or die "can't delete from groupname table: ". $sth->errstr;
 598   }
 599   $dbh->disconnect;
 600 }
 601
 602 sub sqlradius_rename { #subroutine, not method
 603
 604   if ( $FS::svc_Common::noexport_hack ) {
 605     carp 'sqlradius_rename() suppressed by noexport_hack' if $DEBUG;
 606     return;
 607   }
 608
 609   my $dbh = sqlradius_connect(shift, shift, shift);
 610   my($new_username, $old_username) = (shift, shift);
 611   my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
 612   foreach my $table (qw(radreply radcheck), $usergroup ) {
 613     my $sth = $dbh->prepare("UPDATE $table SET Username = ? WHERE UserName = ?")
 614       or die $dbh->errstr;
 615     $sth->execute($new_username, $old_username)
 616       or die "can't update $table: ". $sth->errstr;
 617   }
 618   $dbh->disconnect;
 619 }
 620
 621 sub sqlradius_attrib_delete { #subroutine, not method
 622
 623   if ( $FS::svc_Common::noexport_hack ) {
 624     carp 'sqlradius_attrib_delete() suppressed by noexport_hack' if $DEBUG;
 625     return;
 626   }
 627
 628   my $dbh = sqlradius_connect(shift, shift, shift);
 629   my( $table, $username, @attrib ) = @_;
 630
 631   foreach my $attribute ( @attrib ) {
 632     my $sth = $dbh->prepare(
 633         "DELETE FROM rad$table WHERE UserName = ? AND Attribute = ?" )
 634       or die $dbh->errstr;
 635     $sth->execute($username,$attribute)
 636       or die "can't delete from rad$table table: ". $sth->errstr;
 637   }
 638   $dbh->disconnect;
 639 }
 640
 641 sub sqlradius_delete { #subroutine, not method
 642
 643   if ( $FS::svc_Common::noexport_hack ) {
 644     carp 'sqlradius_delete() suppressed by noexport_hack' if $DEBUG;
 645     return;
 646   }
 647
 648   my $dbh = sqlradius_connect(shift, shift, shift);
 649   my $username = shift;
 650   my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
 651
 652   foreach my $table (qw( radcheck radreply), $usergroup ) {
 653     my $sth = $dbh->prepare( "DELETE FROM $table WHERE UserName = ?" );
 654     $sth->execute($username)
 655       or die "can't delete from $table table: ". $sth->errstr;
 656   }
 657   $dbh->disconnect;
 658 }
 659
 660 sub sqlradius_connect {
 661   #my($datasrc, $username, $password) = @_;
 662   #DBI->connect($datasrc, $username, $password) or die $DBI::errstr;
 663   DBI->connect(@_) or die $DBI::errstr;
 664 }
 665
 666 # on success, returns '' in scalar context, ('',$jobnum) in list context
 667 # on error, always just returns error
 668 sub sqlreplace_usergroups {
 669   my ($self, $svcnum, $username, $jobnum, $old, $new) = @_;
 670
 671   # (sorta) false laziness with FS::svc_acct::replace
 672   my @oldgroups = @$old;
 673   my @newgroups = @$new;
 674   my @delgroups = ();
 675   foreach my $oldgroup ( @oldgroups ) {
 676     if ( grep { $oldgroup eq $_ } @newgroups ) {
 677       @newgroups = grep { $oldgroup ne $_ } @newgroups;
 678       next;
 679     }
 680     push @delgroups, $oldgroup;
 681   }
 682
 683   my $usergroup = $self->option('usergroup') || 'usergroup';
 684
 685   if ( @delgroups ) {
 686     my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_delete',
 687       $username, $usergroup, @delgroups );
 688     return $err_or_queue
 689       unless ref($err_or_queue);
 690     if ( $jobnum ) {
 691       my $error = $err_or_queue->depend_insert( $jobnum );
 692       return $error if $error;
 693     }
 694     $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
 695   }
 696
 697   if ( @newgroups ) {
 698     cluck localtime(). ": queuing usergroup_insert for $svcnum ($username) ".
 699           "with ".  join(", ", @newgroups)
 700       if $DEBUG;
 701     my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_insert',
 702       $username, $usergroup, @newgroups );
 703     return $err_or_queue
 704       unless ref($err_or_queue);
 705     if ( $jobnum ) {
 706       my $error = $err_or_queue->depend_insert( $jobnum );
 707       return $error if $error;
 708     }
 709     $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
 710   }
 711   wantarray ? ('',$jobnum) : '';
 712 }
 713
 714
 715 #--
 716
 717 =item usage_sessions HASHREF
 718
 719 =item usage_sessions TIMESTAMP_START TIMESTAMP_END [ SVC_ACCT [ IP [ PREFIX [ SQL_SELECT ] ] ] ]
 720
 721 New-style: pass a hashref with the following keys:
 722
 723 =over 4
 724
 725 =item stoptime_start - Lower bound for AcctStopTime, as a UNIX timestamp
 726
 727 =item stoptime_end - Upper bound for AcctStopTime, as a UNIX timestamp
 728
 729 =item session_status - 'closed' to only show records with AcctStopTime,
 730 'open' to only show records I<without> AcctStopTime, empty to show both.
 731
 732 =item starttime_start - Lower bound for AcctStartTime, as a UNIX timestamp
 733
 734 =item starttime_end - Upper bound for AcctStartTime, as a UNIX timestamp
 735
 736 =item svc_acct
 737
 738 =item ip
 739
 740 =item prefix
 741
 742 =back
 743
 744 Old-style:
 745
 746 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 747 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 748 functions.
 749
 750 SVC_ACCT, if specified, limits the results to the specified account.
 751
 752 IP, if specified, limits the results to the specified IP address.
 753
 754 PREFIX, if specified, limits the results to records with a matching
 755 Called-Station-ID.
 756
 757 #SQL_SELECT defaults to * if unspecified.  It can be useful to set it to
 758 #SUM(acctsessiontime) or SUM(AcctInputOctets), etc.
 759
 760 Returns an arrayref of hashrefs with the following fields:
 761
 762 =over 4
 763
 764 =item username
 765
 766 =item framedipaddress
 767
 768 =item acctstarttime
 769
 770 =item acctstoptime
 771
 772 =item acctsessiontime
 773
 774 =item acctinputoctets
 775
 776 =item acctoutputoctets
 777
 778 =item callingstationid
 779
 780 =item calledstationid
 781
 782 =back
 783
 784 =cut
 785
 786 #some false laziness w/cust_svc::seconds_since_sqlradacct
 787
 788 sub usage_sessions {
 789   my( $self ) = shift;
 790
 791   my $opt = {};
 792   my($start, $end, $svc_acct, $ip, $prefix) = ( '', '', '', '', '');
 793   my $summarize = 0;
 794   if ( ref($_[0]) ) {
 795     $opt = shift;
 796     $start    = $opt->{stoptime_start};
 797     $end      = $opt->{stoptime_end};
 798     $svc_acct = $opt->{svc} || $opt->{svc_acct};
 799     $ip       = $opt->{ip};
 800     $prefix   = $opt->{prefix};
 801     $summarize   = $opt->{summarize};
 802   } else {
 803     ( $start, $end ) = splice(@_, 0, 2);
 804     $svc_acct = @_ ? shift : '';
 805     $ip = @_ ? shift : '';
 806     $prefix = @_ ? shift : '';
 807     #my $select = @_ ? shift : '*';
 808   }
 809
 810   $end ||= 2147483647;
 811
 812   return [] if $self->option('ignore_accounting');
 813
 814   my $dbh = sqlradius_connect( map $self->option($_),
 815                                    qw( datasrc username password ) );
 816
 817   #select a unix time conversion function based on database type
 818   my $str2time = str2time_sql(         $dbh->{Driver}->{Name} );
 819   my $closing  = str2time_sql_closing( $dbh->{Driver}->{Name} );
 820
 821   my @fields = (
 822                  qw( username realm framedipaddress
 823                      acctsessiontime acctinputoctets acctoutputoctets
 824                      callingstationid calledstationid
 825                    ),
 826                  "$str2time acctstarttime $closing as acctstarttime",
 827                  "$str2time acctstoptime  $closing as acctstoptime",
 828                );
 829
 830   @fields = ( 'username', 'sum(acctsessiontime) as acctsessiontime', 'sum(acctinputoctets) as acctinputoctets',
 831               'sum(acctoutputoctets) as acctoutputoctets',
 832             ) if $summarize;
 833
 834   my @param = ();
 835   my @where = ();
 836
 837   if ( $svc_acct ) {
 838     my $username = $self->export_username($svc_acct);
 839     if ( $username =~ /^([^@]+)\@([^@]+)$/ ) {
 840       push @where, '( UserName = ? OR ( UserName = ? AND Realm = ? ) )';
 841       push @param, $username, $1, $2;
 842     } else {
 843       push @where, 'UserName = ?';
 844       push @param, $username;
 845     }
 846   }
 847
 848   if ($self->option('process_single_realm')) {
 849     push @where, 'Realm = ?';
 850     push @param, $self->option('realm');
 851   }
 852
 853   if ( length($ip) ) {
 854     push @where, ' FramedIPAddress = ?';
 855     push @param, $ip;
 856   }
 857
 858   if ( length($prefix) ) {
 859     #assume sip: for now, else things get ugly trying to match /^\w+:$prefix/
 860     push @where, " CalledStationID LIKE 'sip:$prefix\%'";
 861   }
 862
 863   my $acctstoptime = '';
 864   if ( $opt->{session_status} ne 'open' ) {
 865     if ( $start ) {
 866       $acctstoptime .= "$str2time AcctStopTime $closing >= ?";
 867       push @param, $start;
 868       $acctstoptime .= ' AND ' if $end;
 869     }
 870     if ( $end ) {
 871       $acctstoptime .= "$str2time AcctStopTime $closing <= ?";
 872       push @param, $end;
 873     }
 874   }
 875   if ( $opt->{session_status} ne 'closed' ) {
 876     if ( $acctstoptime ) {
 877       $acctstoptime = "( ( $acctstoptime ) OR AcctStopTime IS NULL )";
 878     } else {
 879       $acctstoptime = 'AcctStopTime IS NULL';
 880     }
 881   }
 882   push @where, $acctstoptime;
 883
 884   if ( $opt->{starttime_start} ) {
 885     push @where, "$str2time AcctStartTime $closing >= ?";
 886     push @param, $opt->{starttime_start};
 887   }
 888   if ( $opt->{starttime_end} ) {
 889     push @where, "$str2time AcctStartTime $closing <= ?";
 890     push @param, $opt->{starttime_end};
 891   }
 892
 893   my $where = join(' AND ', @where);
 894   $where = "WHERE $where" if $where;
 895
 896   my $groupby = '';
 897   $groupby = 'GROUP BY username' if $summarize;
 898
 899   my $orderby = 'ORDER BY AcctStartTime DESC';
 900   $orderby = '' if $summarize;
 901
 902   my $sql = 'SELECT '. join(', ', @fields).
 903             "  FROM radacct $where $groupby $orderby";
 904   if ( $DEBUG ) {
 905     warn $sql;
 906     warn join(',', @param);
 907   }
 908   my $sth = $dbh->prepare($sql) or die $dbh->errstr;
 909   $sth->execute(@param)         or die $sth->errstr;
 910
 911   [ map { { %$_ } } @{ $sth->fetchall_arrayref({}) } ];
 912
 913 }
 914
 915 =item update_svc
 916
 917 =cut
 918
 919 sub update_svc {
 920   my $self = shift;
 921
 922   if ( $FS::svc_Common::noexport_hack ) {
 923     carp 'update_svc() suppressed by noexport_hack'
 924       if $self->option('debug') || $DEBUG;
 925     return;
 926   }
 927
 928   my $conf = new FS::Conf;
 929
 930   my $fdbh = dbh;
 931   my $dbh = sqlradius_connect( map $self->option($_),
 932                                    qw( datasrc username password ) );
 933
 934   my $str2time = str2time_sql(         $dbh->{Driver}->{Name} );
 935   my $closing  = str2time_sql_closing( $dbh->{Driver}->{Name} );
 936
 937   my @fields = qw( radacctid username realm acctsessiontime );
 938
 939   my @param = ();
 940   my $where = '';
 941
 942   my $sth = $dbh->prepare("
 943     SELECT RadAcctId, UserName, Realm, AcctSessionTime,
 944            $str2time AcctStartTime $closing,  $str2time AcctStopTime $closing,
 945            AcctInputOctets, AcctOutputOctets
 946       FROM radacct
 947       WHERE FreesideStatus IS NULL
 948         AND AcctStopTime IS NOT NULL
 949   ") or die $dbh->errstr;
 950   $sth->execute() or die $sth->errstr;
 951
 952   while ( my $row = $sth->fetchrow_arrayref ) {
 953     my($RadAcctId, $UserName, $Realm, $AcctSessionTime, $AcctStartTime,
 954        $AcctStopTime, $AcctInputOctets, $AcctOutputOctets) = @$row;
 955     warn "processing record: ".
 956          "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s"
 957       if $DEBUG;
 958
 959     my $fs_username = $UserName;
 960
 961     $fs_username = lc($fs_username) unless $conf->exists('username-uppercase');
 962
 963     #my %search = ( 'username' => $fs_username );
 964
 965     my $status = '';
 966     my $errinfo = "for RADIUS detail RadAcctID $RadAcctId ".
 967                   "(UserName $UserName, Realm $Realm)";
 968
 969     my $extra_sql = '';
 970     if ( ref($self) =~ /withdomain/ ) { #well, should be a callback to that
 971                                         #module or something
 972       my $domain;
 973       if ( $Realm ) {
 974         $domain = $Realm;
 975       } elsif ( $fs_username =~ /\@/ ) {
 976         ($fs_username, $domain) = split('@', $fs_username);
 977       } else {
 978         warn 'WARNING: nothing Realm column and no @realm in UserName column '.
 979              "$errinfo -- skipping\n" if $DEBUG;
 980         $status = 'skipped (no realm)';
 981       }
 982
 983       $extra_sql = " AND '$domain' = ( SELECT domain FROM svc_domain
 984                           WHERE svc_domain.svcnum = svc_acct.domsvc ) ";
 985     }
 986
 987     my $oldAutoCommit = $FS::UID::AutoCommit; # can't undo side effects, but at
 988     local $FS::UID::AutoCommit = 0;           # least we can avoid over counting
 989
 990     unless ( $status ) {
 991
 992       $status = 'skipped';
 993
 994       if (    $self->option('process_single_realm')
 995            && $self->option('realm') ne $Realm )
 996       {
 997         warn "WARNING: wrong realm $errinfo - skipping\n" if $DEBUG;
 998       } else {
 999         my @svc_acct =
1000           grep { qsearch( 'export_svc', { 'exportnum' => $self->exportnum,
1001                                           'svcpart'   => $_->cust_svc->svcpart,
1002                                         }
1003                         )
1004                }
1005           qsearch( 'svc_acct',
1006                      { 'username' => $fs_username },
1007                      '',
1008                      $extra_sql
1009                    );
1010
1011         if ( !@svc_acct ) {
1012           warn "WARNING: no svc_acct record found $errinfo - skipping\n";
1013         } elsif ( scalar(@svc_acct) > 1 ) {
1014           warn "WARNING: multiple svc_acct records found $errinfo - skipping\n";
1015         } else {
1016
1017           my $svc_acct = $svc_acct[0];
1018           warn "found svc_acct ". $svc_acct->svcnum. " $errinfo\n" if $DEBUG;
1019
1020           $svc_acct->last_login($AcctStartTime);
1021           $svc_acct->last_logout($AcctStopTime);
1022
1023           my $session_time = $AcctStopTime;
1024           $session_time = $AcctStartTime
1025             if $self->option('ignore_long_sessions');
1026
1027           my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
1028           if ( $cust_pkg && $session_time < (    $cust_pkg->last_bill
1029                                               || $cust_pkg->setup     )  ) {
1030             $status = 'skipped (too old)';
1031           } else {
1032             my @st;
1033             push @st, _try_decrement($svc_acct,'seconds',    $AcctSessionTime);
1034             push @st, _try_decrement($svc_acct,'upbytes',    $AcctInputOctets);
1035             push @st, _try_decrement($svc_acct,'downbytes',  $AcctOutputOctets);
1036             push @st, _try_decrement($svc_acct,'totalbytes', $AcctInputOctets
1037                                                            + $AcctOutputOctets);
1038             $status=join(' ', @st);
1039           }
1040         }
1041       }
1042
1043     }
1044
1045     warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG;
1046     my $psth = $dbh->prepare("UPDATE radacct
1047                                 SET FreesideStatus = ?
1048                                 WHERE RadAcctId = ?"
1049     ) or die $dbh->errstr;
1050     $psth->execute($status, $RadAcctId) or die $psth->errstr;
1051
1052     $fdbh->commit or die $fdbh->errstr if $oldAutoCommit;
1053
1054   }
1055
1056 }
1057
1058 sub _try_decrement {
1059   my ($svc_acct, $column, $amount) = @_;
1060   if ( $svc_acct->$column !~ /^$/ ) {
1061     warn "  svc_acct.$column found (". $svc_acct->$column.
1062          ") - decrementing\n"
1063       if $DEBUG;
1064     my $method = 'decrement_' . $column;
1065     my $error = $svc_acct->$method($amount);
1066     die $error if $error;
1067     return 'done';
1068   } else {
1069     warn "  no existing $column value for svc_acct - skipping\n" if $DEBUG;
1070   }
1071   return 'skipped';
1072 }
1073
1074 =item export_nas_insert NAS
1075
1076 =item export_nas_delete NAS
1077
1078 =item export_nas_replace NEW_NAS OLD_NAS
1079
1080 Update the NAS table (allowed RADIUS clients) on the attached RADIUS
1081 server.  Currently requires the table to be named 'nas' and to follow
1082 the stock schema (/etc/freeradius/nas.sql).
1083
1084 =cut
1085
1086 sub export_nas_insert {  shift->export_nas_action('insert', @_); }
1087 sub export_nas_delete {  shift->export_nas_action('delete', @_); }
1088 sub export_nas_replace { shift->export_nas_action('replace', @_); }
1089
1090 sub export_nas_action {
1091   my $self = shift;
1092   my ($action, $new, $old) = @_;
1093
1094   if ( $FS::svc_Common::noexport_hack ) {
1095     carp "export_nas_action($action) suppressed by noexport_hack"
1096       if $self->option('debug') || $DEBUG;
1097     return;
1098   }
1099
1100   # find the NAS in the target table by its name
1101   my $nasname = ($action eq 'replace') ? $old->nasname : $new->nasname;
1102   my $nasnum = $new->nasnum;
1103
1104   my $err_or_queue = $self->sqlradius_queue('', "nas_$action",
1105     nasname => $nasname,
1106     nasnum => $nasnum
1107   );
1108   return $err_or_queue unless ref $err_or_queue;
1109   '';
1110 }
1111
1112 sub sqlradius_nas_insert {
1113
1114   if ( $FS::svc_Common::noexport_hack ) {
1115     carp 'sqlradius_nas_insert() suppressed by noexport_hack' if $DEBUG;
1116     return;
1117   }
1118
1119   my $dbh = sqlradius_connect(shift, shift, shift);
1120   my %opt = @_;
1121   my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
1122     or die "nasnum ".$opt{'nasnum'}.' not found';
1123   # insert actual NULLs where FS::Record has translated to empty strings
1124   my @values = map { length($nas->$_) ? $nas->$_ : undef }
1125     qw( nasname shortname type secret server community description );
1126   my $sth = $dbh->prepare('INSERT INTO nas
1127 (nasname, shortname, type, secret, server, community, description)
1128 VALUES (?, ?, ?, ?, ?, ?, ?)');
1129   $sth->execute(@values) or die $dbh->errstr;
1130 }
1131
1132 sub sqlradius_nas_delete {
1133
1134   if ( $FS::svc_Common::noexport_hack ) {
1135     carp 'sqlradius_nas_delete() suppressed by noexport_hack' if $DEBUG;
1136     return;
1137   }
1138
1139   my $dbh = sqlradius_connect(shift, shift, shift);
1140   my %opt = @_;
1141   my $sth = $dbh->prepare('DELETE FROM nas WHERE nasname = ?');
1142   $sth->execute($opt{'nasname'}) or die $dbh->errstr;
1143 }
1144
1145 sub sqlradius_nas_replace {
1146
1147   if ( $FS::svc_Common::noexport_hack ) {
1148     carp 'sqlradius_nas_replace() suppressed by noexport_hack' if $DEBUG;
1149     return;
1150   }
1151
1152   my $dbh = sqlradius_connect(shift, shift, shift);
1153   my %opt = @_;
1154   my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
1155     or die "nasnum ".$opt{'nasnum'}.' not found';
1156   my @values = map {$nas->$_}
1157     qw( nasname shortname type secret server community description );
1158   my $sth = $dbh->prepare('UPDATE nas SET
1159     nasname = ?, shortname = ?, type = ?, secret = ?,
1160     server = ?, community = ?, description = ?
1161     WHERE nasname = ?');
1162   $sth->execute(@values, $opt{'nasname'}) or die $dbh->errstr;
1163 }
1164
1165 =item export_attr_insert RADIUS_ATTR
1166
1167 =item export_attr_delete RADIUS_ATTR
1168
1169 =item export_attr_replace NEW_RADIUS_ATTR OLD_RADIUS_ATTR
1170
1171 Update the group attribute tables (radgroupcheck and radgroupreply) on
1172 the RADIUS server.  In delete and replace actions, the existing records
1173 are identified by the combination of group name and attribute name.
1174
1175 In the special case where attributes are being replaced because a group
1176 name (L<FS::radius_group>->groupname) is changing, the pseudo-field
1177 'groupname' must be set in OLD_RADIUS_ATTR.
1178
1179 =cut
1180
1181 # some false laziness with NAS export stuff...
1182
1183 sub export_attr_insert  { shift->export_attr_action('insert', @_); }
1184
1185 sub export_attr_delete  { shift->export_attr_action('delete', @_); }
1186
1187 sub export_attr_replace { shift->export_attr_action('replace', @_); }
1188
1189 sub export_attr_action {
1190   my $self = shift;
1191   my ($action, $new, $old) = @_;
1192   my $err_or_queue;
1193
1194   if ( $action eq 'delete' ) {
1195     $old = $new;
1196   }
1197   if ( $action eq 'delete' or $action eq 'replace' ) {
1198     # delete based on an exact match
1199     my %opt = (
1200       attrname  => $old->attrname,
1201       attrtype  => $old->attrtype,
1202       groupname => $old->groupname || $old->radius_group->groupname,
1203       op        => $old->op,
1204       value     => $old->value,
1205     );
1206     $err_or_queue = $self->sqlradius_queue('', 'attr_delete', %opt);
1207     return $err_or_queue unless ref $err_or_queue;
1208   }
1209   # this probably doesn't matter, but just to be safe...
1210   my $jobnum = $err_or_queue->jobnum if $action eq 'replace';
1211   if ( $action eq 'replace' or $action eq 'insert' ) {
1212     my %opt = (
1213       attrname  => $new->attrname,
1214       attrtype  => $new->attrtype,
1215       groupname => $new->radius_group->groupname,
1216       op        => $new->op,
1217       value     => $new->value,
1218     );
1219     $err_or_queue = $self->sqlradius_queue('', 'attr_insert', %opt);
1220     $err_or_queue->depend_insert($jobnum) if $jobnum;
1221     return $err_or_queue unless ref $err_or_queue;
1222   }
1223   '';
1224 }
1225
1226 sub sqlradius_attr_insert {
1227
1228   if ( $FS::svc_Common::noexport_hack ) {
1229     carp 'sqlradius_attr_insert() suppressed by noexport_hack' if $DEBUG;
1230     return;
1231   }
1232
1233   my $dbh = sqlradius_connect(shift, shift, shift);
1234   my %opt = @_;
1235
1236   my $table;
1237   # make sure $table is completely safe
1238   if ( $opt{'attrtype'} eq 'C' ) {
1239     $table = 'radgroupcheck';
1240   }
1241   elsif ( $opt{'attrtype'} eq 'R' ) {
1242     $table = 'radgroupreply';
1243   }
1244   else {
1245     die "unknown attribute type '$opt{attrtype}'";
1246   }
1247
1248   my @values = @opt{ qw(groupname attrname op value) };
1249   my $sth = $dbh->prepare(
1250     'INSERT INTO '.$table.' (groupname, attribute, op, value) VALUES (?,?,?,?)'
1251   );
1252   $sth->execute(@values) or die $dbh->errstr;
1253 }
1254
1255 sub sqlradius_attr_delete {
1256
1257   if ( $FS::svc_Common::noexport_hack ) {
1258     carp 'sqlradius_attr_delete() suppressed by noexport_hack' if $DEBUG;
1259     return;
1260   }
1261
1262   my $dbh = sqlradius_connect(shift, shift, shift);
1263   my %opt = @_;
1264
1265   my $table;
1266   if ( $opt{'attrtype'} eq 'C' ) {
1267     $table = 'radgroupcheck';
1268   }
1269   elsif ( $opt{'attrtype'} eq 'R' ) {
1270     $table = 'radgroupreply';
1271   }
1272   else {
1273     die "unknown attribute type '".$opt{'attrtype'}."'";
1274   }
1275
1276   my @values = @opt{ qw(groupname attrname op value) };
1277   my $sth = $dbh->prepare(
1278     'DELETE FROM '.$table.
1279     ' WHERE groupname = ? AND attribute = ? AND op = ? AND value = ?'.
1280     ' LIMIT 1'
1281   );
1282   $sth->execute(@values) or die $dbh->errstr;
1283 }
1284
1285 #sub sqlradius_attr_replace { no longer needed
1286
1287 =item export_group_replace NEW OLD
1288
1289 Replace the L<FS::radius_group> object OLD with NEW.  This will change
1290 the group name and priority in all radusergroup records, and the group
1291 name in radgroupcheck and radgroupreply.
1292
1293 =cut
1294
1295 sub export_group_replace {
1296   my $self = shift;
1297   my ($new, $old) = @_;
1298   return '' if $new->groupname eq $old->groupname
1299            and $new->priority  == $old->priority;
1300
1301   my $err_or_queue = $self->sqlradius_queue(
1302     '',
1303     'group_replace',
1304     ($self->option('usergroup') || 'usergroup'),
1305     $new->hashref,
1306     $old->hashref,
1307   );
1308   return $err_or_queue unless ref $err_or_queue;
1309   '';
1310 }
1311
1312 sub sqlradius_group_replace {
1313
1314   if ( $FS::svc_Common::noexport_hack ) {
1315     carp 'sqlradius_group_replace() suppressed by noexport_hack' if $DEBUG;
1316     return;
1317   }
1318
1319   my $dbh = sqlradius_connect(shift, shift, shift);
1320   my $usergroup = shift;
1321   $usergroup =~ /^(rad)?usergroup$/
1322     or die "bad usergroup table name: $usergroup";
1323   my ($new, $old) = (shift, shift);
1324   # apply renames to check/reply attribute tables
1325   if ( $new->{'groupname'} ne $old->{'groupname'} ) {
1326     foreach my $table (qw(radgroupcheck radgroupreply)) {
1327       my $sth = $dbh->prepare(
1328         'UPDATE '.$table.' SET groupname = ? WHERE groupname = ?'
1329       );
1330       $sth->execute($new->{'groupname'}, $old->{'groupname'})
1331         or die $dbh->errstr;
1332     }
1333   }
1334   # apply renames and priority changes to usergroup table
1335   my $sth = $dbh->prepare(
1336     'UPDATE '.$usergroup.' SET groupname = ?, priority = ? WHERE groupname = ?'
1337   );
1338   $sth->execute($new->{'groupname'}, $new->{'priority'}, $old->{'groupname'})
1339     or die $dbh->errstr;
1340 }
1341
1342 =item sqlradius_user_disconnect
1343
1344 For a specified user, sends a disconnect request to all nas in the server database.
1345
1346 Accepts L</sqlradius_connect> connection input and the following named parameters:
1347
1348 I<disconnect_ssh> - user@host with access to radclient program (required)
1349
1350 I<svc_acct_username> - the user to be disconnected (required)
1351
1352 I<disconnect_port> - the port (on the nas) to send disconnect requests to (defaults to 1700)
1353
1354 Note this is NOT the opposite of sqlradius_connect.
1355
1356 =cut
1357
1358 sub sqlradius_user_disconnect {
1359
1360   if ( $FS::svc_Common::noexport_hack ) {
1361     carp 'sqlradius_user_disconnect() suppressed by noexport_hack' if $DEBUG;
1362     return;
1363   }
1364
1365   my $dbh = sqlradius_connect(shift, shift, shift);
1366   my %opt = @_;
1367   # get list of nas
1368   my $sth = $dbh->prepare('select nasname, secret from nas') or die $dbh->errstr;
1369   $sth->execute() or die $dbh->errstr;
1370   my $nas = $sth->fetchall_arrayref({});
1371   $sth->finish();
1372   $dbh->disconnect();
1373   die "No nas found in radius db" unless @$nas;
1374   # set up ssh connection
1375   my $ssh = Net::OpenSSH->new($opt{'disconnect_ssh'});
1376   die "Couldn't establish SSH connection: " . $ssh->error
1377     if $ssh->error;
1378   # send individual disconnect requests
1379   my $user = $opt{'svc_acct_username'}; #svc_acct username
1380   my $port = $opt{'disconnect_port'} || 1700; #or should we pull this from the db?
1381   my $error = '';
1382   foreach my $nas (@$nas) {
1383     my $nasname = $nas->{'nasname'};
1384     my $secret  = $nas->{'secret'};
1385     my $command = qq(echo "User-Name=$user" | radclient -r 1 $nasname:$port disconnect '$secret');
1386     my ($output, $errput) = $ssh->capture2($command);
1387     $error .= "Error running $command: $errput " . $ssh->error . " "
1388       if $errput || $ssh->error;
1389   }
1390   $error .= "Some clients may have successfully disconnected"
1391     if $error && (@$nas > 1);
1392   $error = "No clients found"
1393     unless @$nas;
1394   die $error if $error;
1395   return '';
1396 }
1397
1398 ###
1399 # class method to fetch groups/attributes from the sqlradius install on upgrade
1400 ###
1401
1402 sub _upgrade_exporttype {
1403   # do this only if the radius_attr table is empty
1404   local $FS::radius_attr::noexport_hack = 1;
1405   my $class = shift;
1406   return if qsearch('radius_attr', {});
1407
1408   foreach my $self ($class->all_sqlradius) {
1409     my $error = $self->import_attrs;
1410     die "exportnum ".$self->exportnum.":\n$error\n" if $error;
1411   }
1412   return;
1413 }
1414
1415 sub import_attrs {
1416   my $self = shift;
1417   my $dbh =  DBI->connect( map $self->option($_),
1418                                    qw( datasrc username password ) );
1419   unless ( $dbh ) {
1420     warn "Error connecting to RADIUS server: $DBI::errstr\n";
1421     return;
1422   }
1423
1424   my $usergroup = $self->option('usergroup') || 'usergroup';
1425   my $error;
1426   warn "Importing RADIUS groups and attributes from ".$self->option('datasrc').
1427     "\n";
1428
1429   # map out existing groups and attrs
1430   my %attrs_of;
1431   my %groupnum_of;
1432   foreach my $radius_group ( qsearch('radius_group', {}) ) {
1433     $attrs_of{$radius_group->groupname} = +{
1434       map { $_->attrname => $_ } $radius_group->radius_attr
1435     };
1436     $groupnum_of{$radius_group->groupname} = $radius_group->groupnum;
1437   }
1438
1439   # get groupnames from radgroupcheck and radgroupreply
1440   my $sql = '
1441 SELECT groupname, attribute, op, value, \'C\' FROM radgroupcheck
1442 UNION
1443 SELECT groupname, attribute, op, value, \'R\' FROM radgroupreply';
1444   my @fixes; # things that need to be changed on the radius db
1445   foreach my $row ( @{ $dbh->selectall_arrayref($sql) } ) {
1446     my ($groupname, $attrname, $op, $value, $attrtype) = @$row;
1447     warn "$groupname.$attrname\n";
1448     if ( !exists($groupnum_of{$groupname}) ) {
1449       my $radius_group = new FS::radius_group {
1450         'groupname' => $groupname,
1451         'priority'  => 1,
1452       };
1453       $error = $radius_group->insert;
1454       if ( $error ) {
1455         warn "error inserting group $groupname: $error";
1456         next;#don't continue trying to insert the attribute
1457       }
1458       $attrs_of{$groupname} = {};
1459       $groupnum_of{$groupname} = $radius_group->groupnum;
1460     }
1461
1462     my $a = $attrs_of{$groupname};
1463     my $old = $a->{$attrname};
1464     my $new;
1465
1466     if ( $attrtype eq 'R' ) {
1467       # Freeradius tolerates illegal operators in reply attributes.  We don't.
1468       if ( !grep ($_ eq $op, FS::radius_attr->ops('R')) ) {
1469         warn "$groupname.$attrname: changing $op to +=\n";
1470         # Make a note to change it in the db
1471         push @fixes, [
1472           'UPDATE radgroupreply SET op = \'+=\' WHERE groupname = ? AND attribute = ? AND op = ? AND VALUE = ?',
1473           $groupname, $attrname, $op, $value
1474         ];
1475         # and import it correctly.
1476         $op = '+=';
1477       }
1478     }
1479
1480     if ( defined $old ) {
1481       # replace
1482       $new = new FS::radius_attr {
1483         $old->hash,
1484         'op'    => $op,
1485         'value' => $value,
1486       };
1487       $error = $new->replace($old);
1488       if ( $error ) {
1489         warn "error modifying attr $attrname: $error";
1490         next;
1491       }
1492     }
1493     else {
1494       $new = new FS::radius_attr {
1495         'groupnum' => $groupnum_of{$groupname},
1496         'attrname' => $attrname,
1497         'attrtype' => $attrtype,
1498         'op'       => $op,
1499         'value'    => $value,
1500       };
1501       $error = $new->insert;
1502       if ( $error ) {
1503         warn "error inserting attr $attrname: $error" if $error;
1504         next;
1505       }
1506     }
1507     $attrs_of{$groupname}->{$attrname} = $new;
1508   } #foreach $row
1509
1510   foreach (@fixes) {
1511     my ($sql, @args) = @$_;
1512     my $sth = $dbh->prepare($sql);
1513     $sth->execute(@args) or warn $sth->errstr;
1514   }
1515
1516   return;
1517 }
1518
1519 ###
1520 #class methods
1521 ###
1522
1523 sub all_sqlradius {
1524   #my $class = shift;
1525
1526   #don't just look for ->can('usage_sessions'), we're sqlradius-specific
1527   # (radiator is supposed to be setup with a radacct table)
1528   #i suppose it would be more slick to look for things that inherit from us..
1529
1530   my @part_export = ();
1531   push @part_export, qsearch('part_export', { 'exporttype' => $_ } )
1532     foreach qw( sqlradius sqlradius_withdomain radiator phone_sqlradius
1533                 broadband_sqlradius );
1534   @part_export;
1535 }
1536
1537 sub all_sqlradius_withaccounting {
1538   my $class = shift;
1539   grep { ! $_->option('ignore_accounting') } $class->all_sqlradius;
1540 }
1541
1542 1;
1543