FS/FS/part_export/sqlradius.pm

   1 package FS::part_export::sqlradius;
   2
   3 use vars qw(@ISA $DEBUG %info %options $notes1 $notes2);
   4 use Tie::IxHash;
   5 use FS::Record qw( dbh qsearch );
   6 use FS::part_export;
   7 use FS::svc_acct;
   8 use FS::export_svc;
   9
  10 @ISA = qw(FS::part_export);
  11
  12 $DEBUG = 0;
  13
  14 tie %options, 'Tie::IxHash',
  15   'datasrc'  => { label=>'DBI data source ' },
  16   'username' => { label=>'Database username' },
  17   'password' => { label=>'Database password' },
  18   'ignore_accounting' => {
  19     type  => 'checkbox',
  20     label => 'Ignore accounting records from this database'
  21   },
  22   'hide_ip' => {
  23     type  => 'checkbox',
  24     label => 'Hide IP address information on session reports',
  25   },
  26   'hide_data' => {
  27     type  => 'checkbox',
  28     label => 'Hide download/upload information on session reports',
  29   },
  30   'show_called_station' => {
  31     type  => 'checkbox',
  32     label => 'Show the Called-Station-ID on session reports',
  33   },
  34 ;
  35
  36 $notes1 = <<'END';
  37 Real-time export of radcheck, radreply and usergroup tables to any SQL database
  38 for <a href="http://www.freeradius.org/">FreeRADIUS</a>,
  39 <a href="http://radius.innercite.com/">ICRADIUS</a>
  40 or <a href="http://www.open.com.au/radiator/">Radiator</a>.
  41 END
  42
  43 $notes2 = <<'END';
  44 An existing RADIUS database will be updated in realtime, but you can use
  45 <a href="../docs/man/bin/freeside-sqlradius-reset">freeside-sqlradius-reset</a>
  46 to delete the entire RADIUS database and repopulate the tables from the
  47 Freeside database.  See the
  48 <a href="http://search.cpan.org/dist/DBI/DBI.pm#connect">DBI documentation</a>
  49 and the
  50 <a href="http://search.cpan.org/search?mode=module&query=DBD%3A%3A">documentation for your DBD</a>
  51 for the exact syntax of a DBI data source.
  52 <ul>
  53   <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.
  54   <li>Using ICRADIUS, add a dummy "op" column to your database:
  55     <blockquote><code>
  56       ALTER&nbsp;TABLE&nbsp;radcheck&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='<br>
  57       ALTER&nbsp;TABLE&nbsp;radreply&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='<br>
  58       ALTER&nbsp;TABLE&nbsp;radgroupcheck&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='<br>
  59       ALTER&nbsp;TABLE&nbsp;radgroupreply&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='
  60     </code></blockquote>
  61   <li>Using Radiator, see the
  62     <a href="http://www.open.com.au/radiator/faq.html#38">Radiator FAQ</a>
  63     for configuration information.
  64 </ul>
  65 END
  66
  67 %info = (
  68   'svc'      => 'svc_acct',
  69   'desc'     => 'Real-time export to SQL-backed RADIUS (FreeRADIUS, ICRADIUS, Radiator)',
  70   'options'  => \%options,
  71   'nodomain' => 'Y',
  72   'notes'    => $notes1.
  73                 'This export does not export RADIUS realms (see also '.
  74                 'sqlradius_withdomain).  '.
  75                 $notes2
  76 );
  77
  78 sub rebless { shift; }
  79
  80 sub export_username {
  81   my($self, $svc_acct) = (shift, shift);
  82   warn "export_username called on $self with arg $svc_acct" if $DEBUG;
  83   $svc_acct->username;
  84 }
  85
  86 sub _export_insert {
  87   my($self, $svc_acct) = (shift, shift);
  88
  89   foreach my $table (qw(reply check)) {
  90     my $method = "radius_$table";
  91     my %attrib = $svc_acct->$method();
  92     next unless keys %attrib;
  93     my $err_or_queue = $self->sqlradius_queue( $svc_acct->svcnum, 'insert',
  94       $table, $self->export_username($svc_acct), %attrib );
  95     return $err_or_queue unless ref($err_or_queue);
  96   }
  97   my @groups = $svc_acct->radius_groups;
  98   if ( @groups ) {
  99     my $err_or_queue = $self->sqlradius_queue(
 100       $svc_acct->svcnum, 'usergroup_insert',
 101       $self->export_username($svc_acct), @groups );
 102     return $err_or_queue unless ref($err_or_queue);
 103   }
 104   '';
 105 }
 106
 107 sub _export_replace {
 108   my( $self, $new, $old ) = (shift, shift, shift);
 109
 110   local $SIG{HUP} = 'IGNORE';
 111   local $SIG{INT} = 'IGNORE';
 112   local $SIG{QUIT} = 'IGNORE';
 113   local $SIG{TERM} = 'IGNORE';
 114   local $SIG{TSTP} = 'IGNORE';
 115   local $SIG{PIPE} = 'IGNORE';
 116
 117   my $oldAutoCommit = $FS::UID::AutoCommit;
 118   local $FS::UID::AutoCommit = 0;
 119   my $dbh = dbh;
 120
 121   my $jobnum = '';
 122   if ( $self->export_username($old) ne $self->export_username($new) ) {
 123     my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'rename',
 124       $self->export_username($new), $self->export_username($old) );
 125     unless ( ref($err_or_queue) ) {
 126       $dbh->rollback if $oldAutoCommit;
 127       return $err_or_queue;
 128     }
 129     $jobnum = $err_or_queue->jobnum;
 130   }
 131
 132   foreach my $table (qw(reply check)) {
 133     my $method = "radius_$table";
 134     my %new = $new->$method();
 135     my %old = $old->$method();
 136     if ( grep { !exists $old{$_} #new attributes
 137                 || $new{$_} ne $old{$_} #changed
 138               } keys %new
 139     ) {
 140       my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
 141         $table, $self->export_username($new), %new );
 142       unless ( ref($err_or_queue) ) {
 143         $dbh->rollback if $oldAutoCommit;
 144         return $err_or_queue;
 145       }
 146       if ( $jobnum ) {
 147         my $error = $err_or_queue->depend_insert( $jobnum );
 148         if ( $error ) {
 149           $dbh->rollback if $oldAutoCommit;
 150           return $error;
 151         }
 152       }
 153     }
 154
 155     my @del = grep { !exists $new{$_} } keys %old;
 156     if ( @del ) {
 157       my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'attrib_delete',
 158         $table, $self->export_username($new), @del );
 159       unless ( ref($err_or_queue) ) {
 160         $dbh->rollback if $oldAutoCommit;
 161         return $err_or_queue;
 162       }
 163       if ( $jobnum ) {
 164         my $error = $err_or_queue->depend_insert( $jobnum );
 165         if ( $error ) {
 166           $dbh->rollback if $oldAutoCommit;
 167           return $error;
 168         }
 169       }
 170     }
 171   }
 172
 173   # (sorta) false laziness with FS::svc_acct::replace
 174   my @oldgroups = @{$old->usergroup}; #uuuh
 175   my @newgroups = $new->radius_groups;
 176   my @delgroups = ();
 177   foreach my $oldgroup ( @oldgroups ) {
 178     if ( grep { $oldgroup eq $_ } @newgroups ) {
 179       @newgroups = grep { $oldgroup ne $_ } @newgroups;
 180       next;
 181     }
 182     push @delgroups, $oldgroup;
 183   }
 184
 185   if ( @delgroups ) {
 186     my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'usergroup_delete',
 187       $self->export_username($new), @delgroups );
 188     unless ( ref($err_or_queue) ) {
 189       $dbh->rollback if $oldAutoCommit;
 190       return $err_or_queue;
 191     }
 192     if ( $jobnum ) {
 193       my $error = $err_or_queue->depend_insert( $jobnum );
 194       if ( $error ) {
 195         $dbh->rollback if $oldAutoCommit;
 196         return $error;
 197       }
 198     }
 199   }
 200
 201   if ( @newgroups ) {
 202     my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'usergroup_insert',
 203       $self->export_username($new), @newgroups );
 204     unless ( ref($err_or_queue) ) {
 205       $dbh->rollback if $oldAutoCommit;
 206       return $err_or_queue;
 207     }
 208     if ( $jobnum ) {
 209       my $error = $err_or_queue->depend_insert( $jobnum );
 210       if ( $error ) {
 211         $dbh->rollback if $oldAutoCommit;
 212         return $error;
 213       }
 214     }
 215   }
 216
 217   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 218
 219   '';
 220 }
 221
 222 sub _export_delete {
 223   my( $self, $svc_acct ) = (shift, shift);
 224   my $err_or_queue = $self->sqlradius_queue( $svc_acct->svcnum, 'delete',
 225     $self->export_username($svc_acct) );
 226   ref($err_or_queue) ? '' : $err_or_queue;
 227 }
 228
 229 sub sqlradius_queue {
 230   my( $self, $svcnum, $method ) = (shift, shift, shift);
 231   my $queue = new FS::queue {
 232     'svcnum' => $svcnum,
 233     'job'    => "FS::part_export::sqlradius::sqlradius_$method",
 234   };
 235   $queue->insert(
 236     $self->option('datasrc'),
 237     $self->option('username'),
 238     $self->option('password'),
 239     @_,
 240   ) or $queue;
 241 }
 242
 243 sub sqlradius_insert { #subroutine, not method
 244   my $dbh = sqlradius_connect(shift, shift, shift);
 245   my( $table, $username, %attributes ) = @_;
 246
 247   foreach my $attribute ( keys %attributes ) {
 248
 249     my $s_sth = $dbh->prepare(
 250       "SELECT COUNT(*) FROM rad$table WHERE UserName = ? AND Attribute = ?"
 251     ) or die $dbh->errstr;
 252     $s_sth->execute( $username, $attribute ) or die $s_sth->errstr;
 253
 254     if ( $s_sth->fetchrow_arrayref->[0] ) {
 255
 256       my $u_sth = $dbh->prepare(
 257         "UPDATE rad$table SET Value = ? WHERE UserName = ? AND Attribute = ?"
 258       ) or die $dbh->errstr;
 259       $u_sth->execute($attributes{$attribute}, $username, $attribute)
 260         or die $u_sth->errstr;
 261
 262     } else {
 263
 264       my $i_sth = $dbh->prepare(
 265         "INSERT INTO rad$table ( UserName, Attribute, op, Value ) ".
 266           "VALUES ( ?, ?, ?, ? )"
 267       ) or die $dbh->errstr;
 268       $i_sth->execute(
 269         $username,
 270         $attribute,
 271         ( $attribute =~ /Password/i ? '==' : ':=' ),
 272         $attributes{$attribute},
 273       ) or die $i_sth->errstr;
 274
 275     }
 276
 277   }
 278   $dbh->disconnect;
 279 }
 280
 281 sub sqlradius_usergroup_insert { #subroutine, not method
 282   my $dbh = sqlradius_connect(shift, shift, shift);
 283   my( $username, @groups ) = @_;
 284
 285   my $sth = $dbh->prepare(
 286     "INSERT INTO usergroup ( UserName, GroupName ) VALUES ( ?, ? )"
 287   ) or die $dbh->errstr;
 288   foreach my $group ( @groups ) {
 289     $sth->execute( $username, $group )
 290       or die "can't insert into groupname table: ". $sth->errstr;
 291   }
 292   $dbh->disconnect;
 293 }
 294
 295 sub sqlradius_usergroup_delete { #subroutine, not method
 296   my $dbh = sqlradius_connect(shift, shift, shift);
 297   my( $username, @groups ) = @_;
 298
 299   my $sth = $dbh->prepare(
 300     "DELETE FROM usergroup WHERE UserName = ? AND GroupName = ?"
 301   ) or die $dbh->errstr;
 302   foreach my $group ( @groups ) {
 303     $sth->execute( $username, $group )
 304       or die "can't delete from groupname table: ". $sth->errstr;
 305   }
 306   $dbh->disconnect;
 307 }
 308
 309 sub sqlradius_rename { #subroutine, not method
 310   my $dbh = sqlradius_connect(shift, shift, shift);
 311   my($new_username, $old_username) = @_;
 312   foreach my $table (qw(radreply radcheck usergroup )) {
 313     my $sth = $dbh->prepare("UPDATE $table SET Username = ? WHERE UserName = ?")
 314       or die $dbh->errstr;
 315     $sth->execute($new_username, $old_username)
 316       or die "can't update $table: ". $sth->errstr;
 317   }
 318   $dbh->disconnect;
 319 }
 320
 321 sub sqlradius_attrib_delete { #subroutine, not method
 322   my $dbh = sqlradius_connect(shift, shift, shift);
 323   my( $table, $username, @attrib ) = @_;
 324
 325   foreach my $attribute ( @attrib ) {
 326     my $sth = $dbh->prepare(
 327         "DELETE FROM rad$table WHERE UserName = ? AND Attribute = ?" )
 328       or die $dbh->errstr;
 329     $sth->execute($username,$attribute)
 330       or die "can't delete from rad$table table: ". $sth->errstr;
 331   }
 332   $dbh->disconnect;
 333 }
 334
 335 sub sqlradius_delete { #subroutine, not method
 336   my $dbh = sqlradius_connect(shift, shift, shift);
 337   my $username = shift;
 338
 339   foreach my $table (qw( radcheck radreply usergroup )) {
 340     my $sth = $dbh->prepare( "DELETE FROM $table WHERE UserName = ?" );
 341     $sth->execute($username)
 342       or die "can't delete from $table table: ". $sth->errstr;
 343   }
 344   $dbh->disconnect;
 345 }
 346
 347 sub sqlradius_connect {
 348   #my($datasrc, $username, $password) = @_;
 349   #DBI->connect($datasrc, $username, $password) or die $DBI::errstr;
 350   DBI->connect(@_) or die $DBI::errstr;
 351 }
 352
 353 #--
 354
 355 =item usage_sessions TIMESTAMP_START TIMESTAMP_END [ SVC_ACCT [ IP [ PREFIX [ SQL_SELECT ] ] ] ]
 356
 357 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 358 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 359 functions.
 360
 361 SVC_ACCT, if specified, limits the results to the specified account.
 362
 363 IP, if specified, limits the results to the specified IP address.
 364
 365 PREFIX, if specified, limits the results to records with a matching
 366 Called-Station-ID.
 367
 368 #SQL_SELECT defaults to * if unspecified.  It can be useful to set it to
 369 #SUM(acctsessiontime) or SUM(AcctInputOctets), etc.
 370
 371 Returns an arrayref of hashrefs with the following fields:
 372
 373 =over 4
 374
 375 =item username
 376
 377 =item framedipaddress
 378
 379 =item acctstarttime
 380
 381 =item acctstoptime
 382
 383 =item acctsessiontime
 384
 385 =item acctinputoctets
 386
 387 =item acctoutputoctets
 388
 389 =item calledstationid
 390
 391 =back
 392
 393 =cut
 394
 395 #some false laziness w/cust_svc::seconds_since_sqlradacct
 396
 397 sub usage_sessions {
 398   my( $self, $start, $end ) = splice(@_, 0, 3);
 399   my $svc_acct = @_ ? shift : '';
 400   my $ip = @_ ? shift : '';
 401   my $prefix = @_ ? shift : '';
 402   #my $select = @_ ? shift : '*';
 403
 404   $end ||= 2147483647;
 405
 406   return [] if $self->option('ignore_accounting');
 407
 408   my $dbh = sqlradius_connect( map $self->option($_),
 409                                    qw( datasrc username password ) );
 410
 411   #select a unix time conversion function based on database type
 412   my $str2time;
 413   if ( $dbh->{Driver}->{Name} =~ /^mysql(PP)?$/ ) {
 414     $str2time = 'UNIX_TIMESTAMP(';
 415   } elsif ( $dbh->{Driver}->{Name} eq 'Pg' ) {
 416     $str2time = 'EXTRACT( EPOCH FROM ';
 417   } else {
 418     warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
 419          "; guessing how to convert to UNIX timestamps";
 420     $str2time = 'extract(epoch from ';
 421   }
 422
 423   my @fields = (
 424                  qw( username realm framedipaddress
 425                      acctsessiontime acctinputoctets acctoutputoctets
 426                      calledstationid
 427                    ),
 428                  "$str2time acctstarttime ) as acctstarttime",
 429                  "$str2time acctstoptime ) as acctstoptime",
 430                );
 431
 432   my @param = ();
 433   my $where = '';
 434
 435   if ( $svc_acct ) {
 436     my $username = $self->export_username($svc_acct);
 437     if ( $svc_acct =~ /^([^@]+)\@([^@]+)$/ ) {
 438       $where = '( UserName = ? OR ( UserName = ? AND Realm = ? ) ) AND';
 439       push @param, $username, $1, $2;
 440     } else {
 441       $where = 'UserName = ? AND';
 442       push @param, $username;
 443     }
 444   }
 445
 446   if ( length($ip) ) {
 447     $where .= ' FramedIPAddress = ? AND';
 448     push @param, $ip;
 449   }
 450
 451   if ( length($prefix) ) {
 452     #assume sip: for now, else things get ugly trying to match /^\w+:$prefix/
 453     $where .= " CalledStationID LIKE 'sip:$prefix\%' AND";
 454   }
 455
 456   push @param, $start, $end;
 457
 458   my $sth = $dbh->prepare('SELECT '. join(', ', @fields).
 459                           "  FROM radacct
 460                              WHERE $where
 461                                    $str2time AcctStopTime ) >= ?
 462                                AND $str2time AcctStopTime ) <=  ?
 463                                ORDER BY AcctStartTime DESC
 464   ") or die $dbh->errstr;
 465   $sth->execute(@param) or die $sth->errstr;
 466
 467   [ map { { %$_ } } @{ $sth->fetchall_arrayref({}) } ];
 468
 469 }
 470
 471 =item update_svc_acct
 472
 473 =cut
 474
 475 sub update_svc_acct {
 476   my $self = shift;
 477
 478   my $dbh = sqlradius_connect( map $self->option($_),
 479                                    qw( datasrc username password ) );
 480
 481   my @fields = qw( radacctid username realm acctsessiontime );
 482
 483   my @param = ();
 484   my $where = '';
 485
 486   my $sth = $dbh->prepare("
 487     SELECT RadAcctId, UserName, Realm, AcctSessionTime
 488       FROM radacct
 489       WHERE FreesideStatus IS NULL
 490         AND AcctStopTime != 0
 491   ") or die $dbh->errstr;
 492   $sth->execute() or die $sth->errstr;
 493
 494   while ( my $row = $sth->fetchrow_arrayref ) {
 495     my($RadAcctId, $UserName, $Realm, $AcctSessionTime) = @$row;
 496     warn "processing record: ".
 497          "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s"
 498       if $DEBUG;
 499
 500     my %search = ( 'username' => $UserName );
 501     my $extra_sql = '';
 502     if ( ref($self) =~ /withdomain/ ) { #well...
 503       $extra_sql = " AND '$Realm' = ( SELECT domain FROM svc_domain
 504                           WHERE svc_domain.svcnum = svc_acct.domsvc ) ";
 505       my $svc_domain = qsearch
 506     }
 507
 508     my @svc_acct =
 509       grep { qsearch( 'export_svc', { 'exportnum' => $self->exportnum,
 510                                       'svcpart'   => $_->cust_svc->svcpart, } )
 511            }
 512       qsearch( 'svc_acct',
 513                  { 'username' => $UserName },
 514                  '',
 515                  $extra_sql
 516                );
 517
 518     my $errinfo = "for RADIUS detail RadAcctID $RadAcctId ".
 519                   "(UserName $UserName, Realm $Realm)";
 520     my $status = 'skipped';
 521     if ( !@svc_acct ) {
 522       warn "WARNING: no svc_acct record found $errinfo - skipping\n";
 523     } elsif ( scalar(@svc_acct) > 1 ) {
 524       warn "WARNING: multiple svc_acct records found $errinfo - skipping\n";
 525     } else {
 526       my $svc_acct = $svc_acct[0];
 527       warn "found svc_acct ". $svc_acct->svcnum. " $errinfo\n" if $DEBUG;
 528       if ( $svc_acct->seconds !~ /^$/ ) {
 529         warn "  svc_acct.seconds found (". $svc_acct->seconds.
 530              ") - decrementing\n"
 531           if $DEBUG;
 532         my $error = $svc_acct->decrement_seconds($AcctSessionTime);
 533         die $error if $error;
 534         $status = 'done';
 535       } else {
 536         warn "  no existing seconds value for svc_acct - skiping\n" if $DEBUG;
 537       }
 538     }
 539
 540     warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG;
 541     my $psth = $dbh->prepare("UPDATE radacct
 542                                 SET FreesideStatus = ?
 543                                 WHERE RadAcctId = ?"
 544     ) or die $dbh->errstr;
 545     $psth->execute($status, $RadAcctId) or die $psth->errstr;
 546
 547   }
 548
 549 }
 550
 551 1;
 552