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