1 package FS::part_export::sqlradius;
4 use vars qw(@ISA @EXPORT_OK $DEBUG %info %options $notes1 $notes2);
7 use FS::Record qw( dbh qsearch qsearchs str2time_sql );
13 @ISA = qw(FS::part_export);
14 @EXPORT_OK = qw( sqlradius_connect );
19 tie %options, 'Tie::IxHash',
20 'datasrc' => { label=>'DBI data source ' },
21 'username' => { label=>'Database username' },
22 'password' => { label=>'Database password' },
23 'usergroup' => { label => 'Group table',
25 options => [qw( usergroup radusergroup ) ],
27 'ignore_accounting' => {
29 label => 'Ignore accounting records from this database'
31 'process_single_realm' => {
33 label => 'Only process one realm of accounting records',
35 'realm' => { label => 'The realm of of accounting records to be processed' },
36 'ignore_long_sessions' => {
38 label => 'Ignore sessions which span billing periods',
42 label => 'Hide IP address information on session reports',
46 label => 'Hide download/upload information on session reports',
48 'show_called_station' => {
50 label => 'Show the Called-Station-ID on session reports',
52 'overlimit_groups' => {
53 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)',
59 option_values => sub {
61 map { $_->groupnum, $_->long_description }
62 qsearch('radius_group', {}),
67 'groups_susp_reason' => { label =>
68 'Radius group mapping to reason (via template user) (svcnum|username|username@domain reasonnum|reason)',
73 label => 'Export RADIUS group attributes to this database',
78 Real-time export of <b>radcheck</b>, <b>radreply</b> and <b>usergroup</b>/<b>radusergroup</b>
79 tables to any SQL database for
80 <a href="http://www.freeradius.org/">FreeRADIUS</a>
81 or <a href="http://radius.innercite.com/">ICRADIUS</a>.
85 An existing RADIUS database will be updated in realtime, but you can use
86 <a href="http://www.freeside.biz/mediawiki/index.php/Freeside:1.9:Documentation:Developer/bin/freeside-sqlradius-reset">freeside-sqlradius-reset</a>
87 to delete the entire RADIUS database and repopulate the tables from the
88 Freeside database. See the
89 <a href="http://search.cpan.org/dist/DBI/DBI.pm#connect">DBI documentation</a>
91 <a href="http://search.cpan.org/search?mode=module&query=DBD%3A%3A">documentation for your DBD</a>
92 for the exact syntax of a DBI data source.
94 <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.
95 <li>Using ICRADIUS, add a dummy "op" column to your database:
97 ALTER TABLE radcheck ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='<br>
98 ALTER TABLE radreply ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='<br>
99 ALTER TABLE radgroupcheck ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='<br>
100 ALTER TABLE radgroupreply ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='
102 <li>Using Radiator, see the
103 <a href="http://www.open.com.au/radiator/faq.html#38">Radiator FAQ</a>
104 for configuration information.
110 'desc' => 'Real-time export to SQL-backed RADIUS (FreeRADIUS, ICRADIUS)',
111 'options' => \%options,
113 'nas' => 'Y', # show export_nas selection in UI
115 'This export does not export RADIUS realms (see also '.
116 'sqlradius_withdomain). '.
120 sub _groups_susp_reason_map { map { reverse( /^\s*(\S+)\s*(.*)$/ ) }
121 split( "\n", shift->option('groups_susp_reason'));
124 sub rebless { shift; }
126 sub export_username { # override for other svcdb
127 my($self, $svc_acct) = (shift, shift);
128 warn "export_username called on $self with arg $svc_acct" if $DEBUG > 1;
132 sub radius_reply { #override for other svcdb
133 my($self, $svc_acct) = (shift, shift);
134 $svc_acct->radius_reply;
137 sub radius_check { #override for other svcdb
138 my($self, $svc_acct) = (shift, shift);
139 $svc_acct->radius_check;
143 my($self, $svc_x) = (shift, shift);
145 foreach my $table (qw(reply check)) {
146 my $method = "radius_$table";
147 my %attrib = $self->$method($svc_x);
148 next unless keys %attrib;
149 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'insert',
150 $table, $self->export_username($svc_x), %attrib );
151 return $err_or_queue unless ref($err_or_queue);
153 my @groups = $svc_x->radius_groups('hashref');
155 cluck localtime(). ": queuing usergroup_insert for ". $svc_x->svcnum.
156 " (". $self->export_username($svc_x). " with ". join(", ", @groups)
158 my $usergroup = $self->option('usergroup') || 'usergroup';
159 my $err_or_queue = $self->sqlradius_queue(
160 $svc_x->svcnum, 'usergroup_insert',
161 $self->export_username($svc_x), $usergroup, @groups );
162 return $err_or_queue unless ref($err_or_queue);
167 sub _export_replace {
168 my( $self, $new, $old ) = (shift, shift, shift);
170 local $SIG{HUP} = 'IGNORE';
171 local $SIG{INT} = 'IGNORE';
172 local $SIG{QUIT} = 'IGNORE';
173 local $SIG{TERM} = 'IGNORE';
174 local $SIG{TSTP} = 'IGNORE';
175 local $SIG{PIPE} = 'IGNORE';
177 my $oldAutoCommit = $FS::UID::AutoCommit;
178 local $FS::UID::AutoCommit = 0;
182 if ( $self->export_username($old) ne $self->export_username($new) ) {
183 my $usergroup = $self->option('usergroup') || 'usergroup';
184 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'rename',
185 $self->export_username($new), $self->export_username($old), $usergroup );
186 unless ( ref($err_or_queue) ) {
187 $dbh->rollback if $oldAutoCommit;
188 return $err_or_queue;
190 $jobnum = $err_or_queue->jobnum;
193 foreach my $table (qw(reply check)) {
194 my $method = "radius_$table";
195 my %new = $new->$method();
196 my %old = $old->$method();
197 if ( grep { !exists $old{$_} #new attributes
198 || $new{$_} ne $old{$_} #changed
201 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
202 $table, $self->export_username($new), %new );
203 unless ( ref($err_or_queue) ) {
204 $dbh->rollback if $oldAutoCommit;
205 return $err_or_queue;
208 my $error = $err_or_queue->depend_insert( $jobnum );
210 $dbh->rollback if $oldAutoCommit;
216 my @del = grep { !exists $new{$_} } keys %old;
218 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'attrib_delete',
219 $table, $self->export_username($new), @del );
220 unless ( ref($err_or_queue) ) {
221 $dbh->rollback if $oldAutoCommit;
222 return $err_or_queue;
225 my $error = $err_or_queue->depend_insert( $jobnum );
227 $dbh->rollback if $oldAutoCommit;
235 my (@oldgroups) = $old->radius_groups('hashref');
236 my (@newgroups) = $new->radius_groups('hashref');
237 $error = $self->sqlreplace_usergroups( $new->svcnum,
238 $self->export_username($new),
239 $jobnum ? $jobnum : '',
244 $dbh->rollback if $oldAutoCommit;
248 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
253 sub _export_suspend {
254 my( $self, $svc_acct ) = (shift, shift);
256 my $new = $svc_acct->clone_suspended;
258 local $SIG{HUP} = 'IGNORE';
259 local $SIG{INT} = 'IGNORE';
260 local $SIG{QUIT} = 'IGNORE';
261 local $SIG{TERM} = 'IGNORE';
262 local $SIG{TSTP} = 'IGNORE';
263 local $SIG{PIPE} = 'IGNORE';
265 my $oldAutoCommit = $FS::UID::AutoCommit;
266 local $FS::UID::AutoCommit = 0;
269 my @newgroups = $self->suspended_usergroups($svc_acct);
271 unless (@newgroups) { #don't change password if assigning to a suspended group
273 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
274 'check', $self->export_username($new), $new->radius_check );
275 unless ( ref($err_or_queue) ) {
276 $dbh->rollback if $oldAutoCommit;
277 return $err_or_queue;
283 $self->sqlreplace_usergroups(
285 $self->export_username($new),
287 [ $svc_acct->radius_groups('hashref') ],
291 $dbh->rollback if $oldAutoCommit;
294 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
299 sub _export_unsuspend {
300 my( $self, $svc_acct ) = (shift, shift);
302 local $SIG{HUP} = 'IGNORE';
303 local $SIG{INT} = 'IGNORE';
304 local $SIG{QUIT} = 'IGNORE';
305 local $SIG{TERM} = 'IGNORE';
306 local $SIG{TSTP} = 'IGNORE';
307 local $SIG{PIPE} = 'IGNORE';
309 my $oldAutoCommit = $FS::UID::AutoCommit;
310 local $FS::UID::AutoCommit = 0;
313 my $err_or_queue = $self->sqlradius_queue( $svc_acct->svcnum, 'insert',
314 'check', $self->export_username($svc_acct), $svc_acct->radius_check );
315 unless ( ref($err_or_queue) ) {
316 $dbh->rollback if $oldAutoCommit;
317 return $err_or_queue;
321 my (@oldgroups) = $self->suspended_usergroups($svc_acct);
322 $error = $self->sqlreplace_usergroups(
324 $self->export_username($svc_acct),
327 [ $svc_acct->radius_groups('hashref') ],
330 $dbh->rollback if $oldAutoCommit;
333 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
339 my( $self, $svc_x ) = (shift, shift);
340 my $usergroup = $self->option('usergroup') || 'usergroup';
341 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'delete',
342 $self->export_username($svc_x), $usergroup );
343 ref($err_or_queue) ? '' : $err_or_queue;
346 sub sqlradius_queue {
347 my( $self, $svcnum, $method ) = (shift, shift, shift);
348 my $queue = new FS::queue {
350 'job' => "FS::part_export::sqlradius::sqlradius_$method",
353 $self->option('datasrc'),
354 $self->option('username'),
355 $self->option('password'),
360 sub suspended_usergroups {
361 my ($self, $svc_acct) = (shift, shift);
363 return () unless $svc_acct;
365 #false laziness with FS::part_export::shellcommands
366 #subclass part_export?
368 my $r = $svc_acct->cust_svc->cust_pkg->last_reason('susp');
369 my %reasonmap = $self->_groups_susp_reason_map;
372 $userspec = $reasonmap{$r->reasonnum}
373 if exists($reasonmap{$r->reasonnum});
374 $userspec = $reasonmap{$r->reason}
375 if (!$userspec && exists($reasonmap{$r->reason}));
378 if ($userspec =~ /^\d+$/ ){
379 $suspend_user = qsearchs( 'svc_acct', { 'svcnum' => $userspec } );
380 }elsif ($userspec =~ /^\S+\@\S+$/){
381 my ($username,$domain) = split(/\@/, $userspec);
382 for my $user (qsearch( 'svc_acct', { 'username' => $username } )){
383 $suspend_user = $user if $userspec eq $user->email;
386 $suspend_user = qsearchs( 'svc_acct', { 'username' => $userspec } );
389 return $suspend_user->radius_groups('hashref') if $suspend_user;
393 sub sqlradius_insert { #subroutine, not method
394 my $dbh = sqlradius_connect(shift, shift, shift);
395 my( $table, $username, %attributes ) = @_;
397 foreach my $attribute ( keys %attributes ) {
399 my $s_sth = $dbh->prepare(
400 "SELECT COUNT(*) FROM rad$table WHERE UserName = ? AND Attribute = ?"
401 ) or die $dbh->errstr;
402 $s_sth->execute( $username, $attribute ) or die $s_sth->errstr;
404 if ( $s_sth->fetchrow_arrayref->[0] ) {
406 my $u_sth = $dbh->prepare(
407 "UPDATE rad$table SET Value = ? WHERE UserName = ? AND Attribute = ?"
408 ) or die $dbh->errstr;
409 $u_sth->execute($attributes{$attribute}, $username, $attribute)
410 or die $u_sth->errstr;
414 my $i_sth = $dbh->prepare(
415 "INSERT INTO rad$table ( UserName, Attribute, op, Value ) ".
416 "VALUES ( ?, ?, ?, ? )"
417 ) or die $dbh->errstr;
421 ( $attribute eq 'Password' ? '==' : ':=' ),
422 $attributes{$attribute},
423 ) or die $i_sth->errstr;
431 sub sqlradius_usergroup_insert { #subroutine, not method
432 my $dbh = sqlradius_connect(shift, shift, shift);
433 my $username = shift;
434 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
437 my $s_sth = $dbh->prepare(
438 "SELECT COUNT(*) FROM $usergroup WHERE UserName = ? AND GroupName = ?"
439 ) or die $dbh->errstr;
441 my $sth = $dbh->prepare(
442 "INSERT INTO $usergroup ( UserName, GroupName, Priority ) VALUES ( ?, ?, ? )"
443 ) or die $dbh->errstr;
445 foreach ( @groups ) {
446 my $group = $_->{'groupname'};
447 my $priority = $_->{'priority'};
448 $s_sth->execute( $username, $group ) or die $s_sth->errstr;
449 if ($s_sth->fetchrow_arrayref->[0]) {
450 warn localtime() . ": sqlradius_usergroup_insert attempted to reinsert " .
451 "$group for $username\n"
455 $sth->execute( $username, $group, $priority )
456 or die "can't insert into groupname table: ". $sth->errstr;
458 if ( $s_sth->{Active} ) {
459 warn "sqlradius s_sth still active; calling ->finish()";
462 if ( $sth->{Active} ) {
463 warn "sqlradius sth still active; calling ->finish()";
469 sub sqlradius_usergroup_delete { #subroutine, not method
470 my $dbh = sqlradius_connect(shift, shift, shift);
471 my $username = shift;
472 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
475 my $sth = $dbh->prepare(
476 "DELETE FROM $usergroup WHERE UserName = ? AND GroupName = ?"
477 ) or die $dbh->errstr;
478 foreach ( @groups ) {
479 my $group = $_->{'groupname'};
480 $sth->execute( $username, $group )
481 or die "can't delete from groupname table: ". $sth->errstr;
486 sub sqlradius_rename { #subroutine, not method
487 my $dbh = sqlradius_connect(shift, shift, shift);
488 my($new_username, $old_username) = (shift, shift);
489 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
490 foreach my $table (qw(radreply radcheck), $usergroup ) {
491 my $sth = $dbh->prepare("UPDATE $table SET Username = ? WHERE UserName = ?")
493 $sth->execute($new_username, $old_username)
494 or die "can't update $table: ". $sth->errstr;
499 sub sqlradius_attrib_delete { #subroutine, not method
500 my $dbh = sqlradius_connect(shift, shift, shift);
501 my( $table, $username, @attrib ) = @_;
503 foreach my $attribute ( @attrib ) {
504 my $sth = $dbh->prepare(
505 "DELETE FROM rad$table WHERE UserName = ? AND Attribute = ?" )
507 $sth->execute($username,$attribute)
508 or die "can't delete from rad$table table: ". $sth->errstr;
513 sub sqlradius_delete { #subroutine, not method
514 my $dbh = sqlradius_connect(shift, shift, shift);
515 my $username = shift;
516 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
518 foreach my $table (qw( radcheck radreply), $usergroup ) {
519 my $sth = $dbh->prepare( "DELETE FROM $table WHERE UserName = ?" );
520 $sth->execute($username)
521 or die "can't delete from $table table: ". $sth->errstr;
526 sub sqlradius_connect {
527 #my($datasrc, $username, $password) = @_;
528 #DBI->connect($datasrc, $username, $password) or die $DBI::errstr;
529 DBI->connect(@_) or die $DBI::errstr;
532 sub sqlreplace_usergroups {
533 my ($self, $svcnum, $username, $jobnum, $old, $new) = @_;
535 # (sorta) false laziness with FS::svc_acct::replace
536 my @oldgroups = @$old;
537 my @newgroups = @$new;
539 foreach my $oldgroup ( @oldgroups ) {
540 if ( grep { $oldgroup eq $_ } @newgroups ) {
541 @newgroups = grep { $oldgroup ne $_ } @newgroups;
544 push @delgroups, $oldgroup;
547 my $usergroup = $self->option('usergroup') || 'usergroup';
550 my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_delete',
551 $username, $usergroup, @delgroups );
553 unless ref($err_or_queue);
555 my $error = $err_or_queue->depend_insert( $jobnum );
556 return $error if $error;
561 cluck localtime(). ": queuing usergroup_insert for $svcnum ($username) ".
562 "with ". join(", ", @newgroups)
564 my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_insert',
565 $username, $usergroup, @newgroups );
567 unless ref($err_or_queue);
569 my $error = $err_or_queue->depend_insert( $jobnum );
570 return $error if $error;
579 =item usage_sessions HASHREF
581 =item usage_sessions TIMESTAMP_START TIMESTAMP_END [ SVC_ACCT [ IP [ PREFIX [ SQL_SELECT ] ] ] ]
583 New-style: pass a hashref with the following keys:
587 =item stoptime_start - Lower bound for AcctStopTime, as a UNIX timestamp
589 =item stoptime_end - Upper bound for AcctStopTime, as a UNIX timestamp
591 =item open_sessions - Only show records with no AcctStopTime (typically used without stoptime_* options and with starttime_* options instead)
593 =item starttime_start - Lower bound for AcctStartTime, as a UNIX timestamp
595 =item starttime_end - Upper bound for AcctStartTime, as a UNIX timestamp
607 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
608 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
611 SVC_ACCT, if specified, limits the results to the specified account.
613 IP, if specified, limits the results to the specified IP address.
615 PREFIX, if specified, limits the results to records with a matching
618 #SQL_SELECT defaults to * if unspecified. It can be useful to set it to
619 #SUM(acctsessiontime) or SUM(AcctInputOctets), etc.
621 Returns an arrayref of hashrefs with the following fields:
627 =item framedipaddress
633 =item acctsessiontime
635 =item acctinputoctets
637 =item acctoutputoctets
639 =item calledstationid
645 #some false laziness w/cust_svc::seconds_since_sqlradacct
651 my($start, $end, $svc_acct, $ip, $prefix) = ( '', '', '', '', '');
655 $start = $opt->{stoptime_start};
656 $end = $opt->{stoptime_end};
657 $svc_acct = $opt->{svc_acct};
659 $prefix = $opt->{prefix};
660 $summarize = $opt->{summarize};
662 ( $start, $end ) = splice(@_, 0, 2);
663 $svc_acct = @_ ? shift : '';
664 $ip = @_ ? shift : '';
665 $prefix = @_ ? shift : '';
666 #my $select = @_ ? shift : '*';
671 return [] if $self->option('ignore_accounting');
673 my $dbh = sqlradius_connect( map $self->option($_),
674 qw( datasrc username password ) );
676 #select a unix time conversion function based on database type
677 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
680 qw( username realm framedipaddress
681 acctsessiontime acctinputoctets acctoutputoctets
684 "$str2time acctstarttime ) as acctstarttime",
685 "$str2time acctstoptime ) as acctstoptime",
688 @fields = ( 'username', 'sum(acctsessiontime) as acctsessiontime', 'sum(acctinputoctets) as acctinputoctets',
689 'sum(acctoutputoctets) as acctoutputoctets',
696 my $username = $self->export_username($svc_acct);
697 if ( $username =~ /^([^@]+)\@([^@]+)$/ ) {
698 push @where, '( UserName = ? OR ( UserName = ? AND Realm = ? ) )';
699 push @param, $username, $1, $2;
701 push @where, 'UserName = ?';
702 push @param, $username;
706 if ($self->option('process_single_realm')) {
707 push @where, 'Realm = ?';
708 push @param, $self->option('realm');
712 push @where, ' FramedIPAddress = ?';
716 if ( length($prefix) ) {
717 #assume sip: for now, else things get ugly trying to match /^\w+:$prefix/
718 push @where, " CalledStationID LIKE 'sip:$prefix\%'";
722 push @where, "$str2time AcctStopTime ) >= ?";
726 push @where, "$str2time AcctStopTime ) <= ?";
729 if ( $opt->{open_sessions} ) {
730 push @where, 'AcctStopTime IS NULL';
732 if ( $opt->{starttime_start} ) {
733 push @where, "$str2time AcctStartTime ) >= ?";
734 push @param, $opt->{starttime_start};
736 if ( $opt->{starttime_end} ) {
737 push @where, "$str2time AcctStartTime ) <= ?";
738 push @param, $opt->{starttime_end};
741 my $where = join(' AND ', @where);
742 $where = "WHERE $where" if $where;
745 $groupby = 'GROUP BY username' if $summarize;
747 my $orderby = 'ORDER BY AcctStartTime DESC';
748 $orderby = '' if $summarize;
750 my $sth = $dbh->prepare('SELECT '. join(', ', @fields).
751 " FROM radacct $where $groupby $orderby
752 ") or die $dbh->errstr;
753 $sth->execute(@param) or die $sth->errstr;
755 [ map { { %$_ } } @{ $sth->fetchall_arrayref({}) } ];
759 =item update_svc_acct
766 my $conf = new FS::Conf;
769 my $dbh = sqlradius_connect( map $self->option($_),
770 qw( datasrc username password ) );
772 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
773 my @fields = qw( radacctid username realm acctsessiontime );
778 my $sth = $dbh->prepare("
779 SELECT RadAcctId, UserName, Realm, AcctSessionTime,
780 $str2time AcctStartTime), $str2time AcctStopTime),
781 AcctInputOctets, AcctOutputOctets
783 WHERE FreesideStatus IS NULL
784 AND AcctStopTime IS NOT NULL
785 ") or die $dbh->errstr;
786 $sth->execute() or die $sth->errstr;
788 while ( my $row = $sth->fetchrow_arrayref ) {
789 my($RadAcctId, $UserName, $Realm, $AcctSessionTime, $AcctStartTime,
790 $AcctStopTime, $AcctInputOctets, $AcctOutputOctets) = @$row;
791 warn "processing record: ".
792 "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s"
795 $UserName = lc($UserName) unless $conf->exists('username-uppercase');
797 #my %search = ( 'username' => $UserName );
800 if ( ref($self) =~ /withdomain/ ) { #well...
801 $extra_sql = " AND '$Realm' = ( SELECT domain FROM svc_domain
802 WHERE svc_domain.svcnum = svc_acct.domsvc ) ";
805 my $oldAutoCommit = $FS::UID::AutoCommit; # can't undo side effects, but at
806 local $FS::UID::AutoCommit = 0; # least we can avoid over counting
808 my $status = 'skipped';
809 my $errinfo = "for RADIUS detail RadAcctID $RadAcctId ".
810 "(UserName $UserName, Realm $Realm)";
812 if ( $self->option('process_single_realm')
813 && $self->option('realm') ne $Realm )
815 warn "WARNING: wrong realm $errinfo - skipping\n" if $DEBUG;
818 grep { qsearch( 'export_svc', { 'exportnum' => $self->exportnum,
819 'svcpart' => $_->cust_svc->svcpart, } )
822 { 'username' => $UserName },
828 warn "WARNING: no svc_acct record found $errinfo - skipping\n";
829 } elsif ( scalar(@svc_acct) > 1 ) {
830 warn "WARNING: multiple svc_acct records found $errinfo - skipping\n";
833 my $svc_acct = $svc_acct[0];
834 warn "found svc_acct ". $svc_acct->svcnum. " $errinfo\n" if $DEBUG;
836 $svc_acct->last_login($AcctStartTime);
837 $svc_acct->last_logout($AcctStopTime);
839 my $session_time = $AcctStopTime;
840 $session_time = $AcctStartTime if $self->option('ignore_long_sessions');
842 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
843 if ( $cust_pkg && $session_time < ( $cust_pkg->last_bill
844 || $cust_pkg->setup ) ) {
845 $status = 'skipped (too old)';
848 push @st, _try_decrement($svc_acct, 'seconds', $AcctSessionTime);
849 push @st, _try_decrement($svc_acct, 'upbytes', $AcctInputOctets);
850 push @st, _try_decrement($svc_acct, 'downbytes', $AcctOutputOctets);
851 push @st, _try_decrement($svc_acct, 'totalbytes', $AcctInputOctets
852 + $AcctOutputOctets);
853 $status=join(' ', @st);
858 warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG;
859 my $psth = $dbh->prepare("UPDATE radacct
860 SET FreesideStatus = ?
862 ) or die $dbh->errstr;
863 $psth->execute($status, $RadAcctId) or die $psth->errstr;
865 $fdbh->commit or die $fdbh->errstr if $oldAutoCommit;
872 my ($svc_acct, $column, $amount) = @_;
873 if ( $svc_acct->$column !~ /^$/ ) {
874 warn " svc_acct.$column found (". $svc_acct->$column.
877 my $method = 'decrement_' . $column;
878 my $error = $svc_acct->$method($amount);
879 die $error if $error;
882 warn " no existing $column value for svc_acct - skipping\n" if $DEBUG;
887 =item export_nas_insert NAS
889 =item export_nas_delete NAS
891 =item export_nas_replace NEW_NAS OLD_NAS
893 Update the NAS table (allowed RADIUS clients) on the attached RADIUS
894 server. Currently requires the table to be named 'nas' and to follow
895 the stock schema (/etc/freeradius/nas.sql).
899 sub export_nas_insert { shift->export_nas_action('insert', @_); }
900 sub export_nas_delete { shift->export_nas_action('delete', @_); }
901 sub export_nas_replace { shift->export_nas_action('replace', @_); }
903 sub export_nas_action {
905 my ($action, $new, $old) = @_;
906 # find the NAS in the target table by its name
907 my $nasname = ($action eq 'replace') ? $old->nasname : $new->nasname;
908 my $nasnum = $new->nasnum;
910 my $err_or_queue = $self->sqlradius_queue('', "nas_$action",
914 return $err_or_queue unless ref $err_or_queue;
918 sub sqlradius_nas_insert {
919 my $dbh = sqlradius_connect(shift, shift, shift);
921 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
922 or die "nasnum ".$opt{'nasnum'}.' not found';
923 # insert actual NULLs where FS::Record has translated to empty strings
924 my @values = map { length($nas->$_) ? $nas->$_ : undef }
925 qw( nasname shortname type secret server community description );
926 my $sth = $dbh->prepare('INSERT INTO nas
927 (nasname, shortname, type, secret, server, community, description)
928 VALUES (?, ?, ?, ?, ?, ?, ?)');
929 $sth->execute(@values) or die $dbh->errstr;
932 sub sqlradius_nas_delete {
933 my $dbh = sqlradius_connect(shift, shift, shift);
935 my $sth = $dbh->prepare('DELETE FROM nas WHERE nasname = ?');
936 $sth->execute($opt{'nasname'}) or die $dbh->errstr;
939 sub sqlradius_nas_replace {
940 my $dbh = sqlradius_connect(shift, shift, shift);
942 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
943 or die "nasnum ".$opt{'nasnum'}.' not found';
944 my @values = map {$nas->$_}
945 qw( nasname shortname type secret server community description );
946 my $sth = $dbh->prepare('UPDATE nas SET
947 nasname = ?, shortname = ?, type = ?, secret = ?,
948 server = ?, community = ?, description = ?
950 $sth->execute(@values, $opt{'nasname'}) or die $dbh->errstr;
953 =item export_attr_insert RADIUS_ATTR
955 =item export_attr_delete RADIUS_ATTR
957 =item export_attr_replace NEW_RADIUS_ATTR OLD_RADIUS_ATTR
959 Update the group attribute tables (radgroupcheck and radgroupreply) on
960 the RADIUS server. In delete and replace actions, the existing records
961 are identified by the combination of group name and attribute name.
963 In the special case where attributes are being replaced because a group
964 name (L<FS::radius_group>->groupname) is changing, the pseudo-field
965 'groupname' must be set in OLD_RADIUS_ATTR. It's probably best to do this
970 # some false laziness with NAS export stuff...
972 sub export_attr_insert { shift->export_attr_action('insert', @_); }
974 sub export_attr_delete { shift->export_attr_action('delete', @_); }
976 sub export_attr_replace { shift->export_attr_action('replace', @_); }
978 sub export_attr_action {
980 my ($action, $new, $old) = @_;
981 my ($attrname, $attrtype, $groupname) =
982 ($new->attrname, $new->attrtype, $new->radius_group->groupname);
983 if ( $action eq 'replace' ) {
985 if ( $new->attrtype ne $old->attrtype ) {
986 # they're in separate tables in the target
987 return $self->export_attr_action('delete', $old)
988 || $self->export_attr_action('insert', $new)
992 # otherwise, just make sure we know the old attribute/group names
993 # so we can find the existing record
994 $attrname = $old->attrname;
995 $groupname = $old->groupname || $old->radius_group->groupname;
996 # maybe this should be enforced more strictly
997 warn "WARNING: attribute replace without 'groupname' set; assuming '$groupname'\n"
998 if !defined($old->groupname);
1001 my $err_or_queue = $self->sqlradius_queue('', "attr_$action",
1002 attrnum => $new->attrnum,
1003 attrname => $attrname,
1004 attrtype => $attrtype,
1005 groupname => $groupname,
1007 return $err_or_queue unless ref $err_or_queue;
1011 sub sqlradius_attr_insert {
1012 my $dbh = sqlradius_connect(shift, shift, shift);
1014 my $radius_attr = qsearchs('radius_attr', { attrnum => $opt{'attrnum'} })
1015 or die 'attrnum '.$opt{'attrnum'}.' not found';
1018 # make sure $table is completely safe
1019 if ( $opt{'attrtype'} eq 'C' ) {
1020 $table = 'radgroupcheck';
1022 elsif ( $opt{'attrtype'} eq 'R' ) {
1023 $table = 'radgroupreply';
1026 die "unknown attribute type '".$radius_attr->attrtype."'";
1030 $opt{'groupname'}, map { $radius_attr->$_ } qw(attrname op value)
1032 my $sth = $dbh->prepare(
1033 'INSERT INTO '.$table.' (groupname, attribute, op, value) VALUES (?,?,?,?)'
1035 $sth->execute(@values) or die $dbh->errstr;
1038 sub sqlradius_attr_delete {
1039 my $dbh = sqlradius_connect(shift, shift, shift);
1043 if ( $opt{'attrtype'} eq 'C' ) {
1044 $table = 'radgroupcheck';
1046 elsif ( $opt{'attrtype'} eq 'R' ) {
1047 $table = 'radgroupreply';
1050 die "unknown attribute type '".$opt{'attrtype'}."'";
1053 my $sth = $dbh->prepare(
1054 'DELETE FROM '.$table.' WHERE groupname = ? AND attribute = ?'
1056 $sth->execute( @opt{'groupname', 'attrname'} ) or die $dbh->errstr;
1059 sub sqlradius_attr_replace {
1060 my $dbh = sqlradius_connect(shift, shift, shift);
1062 my $radius_attr = qsearchs('radius_attr', { attrnum => $opt{'attrnum'} })
1063 or die 'attrnum '.$opt{'attrnum'}.' not found';
1066 if ( $opt{'attrtype'} eq 'C' ) {
1067 $table = 'radgroupcheck';
1069 elsif ( $opt{'attrtype'} eq 'R' ) {
1070 $table = 'radgroupreply';
1073 die "unknown attribute type '".$opt{'attrtype'}."'";
1076 my $sth = $dbh->prepare(
1077 'UPDATE '.$table.' SET groupname = ?, attribute = ?, op = ?, value = ?
1078 WHERE groupname = ? AND attribute = ?'
1081 my $new_groupname = $radius_attr->radius_group->groupname;
1083 $new_groupname, map { $radius_attr->$_ } qw(attrname op value)
1085 $sth->execute( @new_values, @opt{'groupname', 'attrname'} )
1086 or die $dbh->errstr;
1089 =item export_group_replace NEW OLD
1091 Replace the L<FS::radius_group> object OLD with NEW. This will change
1092 the group name and priority in all radusergroup records, and the group
1093 name in radgroupcheck and radgroupreply.
1097 sub export_group_replace {
1099 my ($new, $old) = @_;
1100 return '' if $new->groupname eq $old->groupname
1101 and $new->priority == $old->priority;
1103 my $err_or_queue = $self->sqlradius_queue(
1106 ($self->option('usergroup') || 'usergroup'),
1110 return $err_or_queue unless ref $err_or_queue;
1114 sub sqlradius_group_replace {
1115 my $dbh = sqlradius_connect(shift, shift, shift);
1116 my $usergroup = shift;
1117 $usergroup =~ /^(rad)?usergroup$/
1118 or die "bad usergroup table name: $usergroup";
1119 my ($new, $old) = (shift, shift);
1120 # apply renames to check/reply attribute tables
1121 if ( $new->{'groupname'} ne $old->{'groupname'} ) {
1122 foreach my $table (qw(radgroupcheck radgroupreply)) {
1123 my $sth = $dbh->prepare(
1124 'UPDATE '.$table.' SET groupname = ? WHERE groupname = ?'
1126 $sth->execute($new->{'groupname'}, $old->{'groupname'})
1127 or die $dbh->errstr;
1130 # apply renames and priority changes to usergroup table
1131 my $sth = $dbh->prepare(
1132 'UPDATE '.$usergroup.' SET groupname = ?, priority = ? WHERE groupname = ?'
1134 $sth->execute($new->{'groupname'}, $new->{'priority'}, $old->{'groupname'})
1135 or die $dbh->errstr;
1139 # class method to fetch groups/attributes from the sqlradius install on upgrade
1142 sub _upgrade_exporttype {
1143 # do this only if the radius_attr table is empty
1144 local $FS::radius_attr::noexport_hack = 1;
1146 return if qsearch('radius_attr', {});
1148 foreach my $self ($class->all_sqlradius) {
1149 my $error = $self->import_attrs;
1150 die "exportnum ".$self->exportnum.":\n$error\n" if $error;
1157 my $dbh = sqlradius_connect( map $self->option($_),
1158 qw( datasrc username password ) );
1159 my $usergroup = $self->option('usergroup') || 'usergroup';
1161 warn "Importing RADIUS groups and attributes from ".$self->option('datasrc').
1164 # map out existing groups and attrs
1167 foreach my $radius_group ( qsearch('radius_group', {}) ) {
1168 $attrs_of{$radius_group->groupname} = +{
1169 map { $_->attrname => $_ } $radius_group->radius_attr
1171 $groupnum_of{$radius_group->groupname} = $radius_group->groupnum;
1174 # get groupnames from radgroupcheck and radgroupreply
1176 SELECT groupname, attribute, op, value, \'C\' FROM radgroupcheck
1178 SELECT groupname, attribute, op, value, \'R\' FROM radgroupreply';
1179 foreach my $row ( @{ $dbh->selectall_arrayref($sql) } ) {
1180 my ($groupname, $attrname, $op, $value, $attrtype) = @$row;
1181 warn "$groupname.$attrname\n";
1182 if ( !exists($groupnum_of{$groupname}) ) {
1183 my $radius_group = new FS::radius_group {
1184 'groupname' => $groupname,
1187 $error = $radius_group->insert;
1188 return "error inserting group $groupname: $error" if $error;
1189 $attrs_of{$groupname} = {};
1190 $groupnum_of{$groupname} = $radius_group->groupnum;
1193 my $a = $attrs_of{$groupname};
1194 my $old = $a->{$attrname};
1197 if ( defined $old ) {
1199 $new = new FS::radius_attr {
1204 $error = $new->replace($old);
1205 return "error modifying attr $attrname: $error" if $error;
1208 $new = new FS::radius_attr {
1209 'groupnum' => $groupnum_of{$groupname},
1210 'attrname' => $attrname,
1211 'attrtype' => $attrtype,
1215 $error = $new->insert;
1216 return "error inserting attr $attrname: $error" if $error;
1218 $attrs_of{$groupname}->{$attrname} = $new;
1230 #don't just look for ->can('usage_sessions'), we're sqlradius-specific
1231 # (radiator is supposed to be setup with a radacct table)
1232 #i suppose it would be more slick to look for things that inherit from us..
1234 my @part_export = ();
1235 push @part_export, qsearch('part_export', { 'exporttype' => $_ } )
1236 foreach qw( sqlradius sqlradius_withdomain radiator phone_sqlradius
1237 broadband_sqlradius );
1241 sub all_sqlradius_withaccounting {
1243 grep { ! $_->option('ignore_accounting') } $class->all_sqlradius;