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
114 'default_svc_class' => 'Internet',
116 'This export does not export RADIUS realms (see also '.
117 'sqlradius_withdomain). '.
121 sub _groups_susp_reason_map { map { reverse( /^\s*(\S+)\s*(.*)$/ ) }
122 split( "\n", shift->option('groups_susp_reason'));
125 sub rebless { shift; }
127 sub export_username { # override for other svcdb
128 my($self, $svc_acct) = (shift, shift);
129 warn "export_username called on $self with arg $svc_acct" if $DEBUG > 1;
133 sub radius_reply { #override for other svcdb
134 my($self, $svc_acct) = (shift, shift);
135 $svc_acct->radius_reply;
138 sub radius_check { #override for other svcdb
139 my($self, $svc_acct) = (shift, shift);
140 $svc_acct->radius_check;
144 my($self, $svc_x) = (shift, shift);
146 foreach my $table (qw(reply check)) {
147 my $method = "radius_$table";
148 my %attrib = $self->$method($svc_x);
149 next unless keys %attrib;
150 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'insert',
151 $table, $self->export_username($svc_x), %attrib );
152 return $err_or_queue unless ref($err_or_queue);
154 my @groups = $svc_x->radius_groups('hashref');
156 cluck localtime(). ": queuing usergroup_insert for ". $svc_x->svcnum.
157 " (". $self->export_username($svc_x). " with ". join(", ", @groups)
159 my $usergroup = $self->option('usergroup') || 'usergroup';
160 my $err_or_queue = $self->sqlradius_queue(
161 $svc_x->svcnum, 'usergroup_insert',
162 $self->export_username($svc_x), $usergroup, @groups );
163 return $err_or_queue unless ref($err_or_queue);
168 sub _export_replace {
169 my( $self, $new, $old ) = (shift, shift, shift);
171 local $SIG{HUP} = 'IGNORE';
172 local $SIG{INT} = 'IGNORE';
173 local $SIG{QUIT} = 'IGNORE';
174 local $SIG{TERM} = 'IGNORE';
175 local $SIG{TSTP} = 'IGNORE';
176 local $SIG{PIPE} = 'IGNORE';
178 my $oldAutoCommit = $FS::UID::AutoCommit;
179 local $FS::UID::AutoCommit = 0;
183 if ( $self->export_username($old) ne $self->export_username($new) ) {
184 my $usergroup = $self->option('usergroup') || 'usergroup';
185 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'rename',
186 $self->export_username($new), $self->export_username($old), $usergroup );
187 unless ( ref($err_or_queue) ) {
188 $dbh->rollback if $oldAutoCommit;
189 return $err_or_queue;
191 $jobnum = $err_or_queue->jobnum;
194 foreach my $table (qw(reply check)) {
195 my $method = "radius_$table";
196 my %new = $new->$method();
197 my %old = $old->$method();
198 if ( grep { !exists $old{$_} #new attributes
199 || $new{$_} ne $old{$_} #changed
202 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
203 $table, $self->export_username($new), %new );
204 unless ( ref($err_or_queue) ) {
205 $dbh->rollback if $oldAutoCommit;
206 return $err_or_queue;
209 my $error = $err_or_queue->depend_insert( $jobnum );
211 $dbh->rollback if $oldAutoCommit;
215 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
218 my @del = grep { !exists $new{$_} } keys %old;
220 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'attrib_delete',
221 $table, $self->export_username($new), @del );
222 unless ( ref($err_or_queue) ) {
223 $dbh->rollback if $oldAutoCommit;
224 return $err_or_queue;
227 my $error = $err_or_queue->depend_insert( $jobnum );
229 $dbh->rollback if $oldAutoCommit;
233 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
238 my (@oldgroups) = $old->radius_groups('hashref');
239 my (@newgroups) = $new->radius_groups('hashref');
240 $error = $self->sqlreplace_usergroups( $new->svcnum,
241 $self->export_username($new),
242 $jobnum ? $jobnum : '',
247 $dbh->rollback if $oldAutoCommit;
251 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
256 #false laziness w/broadband_sqlradius.pm
257 sub _export_suspend {
258 my( $self, $svc_acct ) = (shift, shift);
260 my $new = $svc_acct->clone_suspended;
262 local $SIG{HUP} = 'IGNORE';
263 local $SIG{INT} = 'IGNORE';
264 local $SIG{QUIT} = 'IGNORE';
265 local $SIG{TERM} = 'IGNORE';
266 local $SIG{TSTP} = 'IGNORE';
267 local $SIG{PIPE} = 'IGNORE';
269 my $oldAutoCommit = $FS::UID::AutoCommit;
270 local $FS::UID::AutoCommit = 0;
273 my @newgroups = $self->suspended_usergroups($svc_acct);
275 unless (@newgroups) { #don't change password if assigning to a suspended group
277 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
278 'check', $self->export_username($new), $new->radius_check );
279 unless ( ref($err_or_queue) ) {
280 $dbh->rollback if $oldAutoCommit;
281 return $err_or_queue;
287 $self->sqlreplace_usergroups(
289 $self->export_username($new),
291 [ $svc_acct->radius_groups('hashref') ],
295 $dbh->rollback if $oldAutoCommit;
298 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
303 sub _export_unsuspend {
304 my( $self, $svc_x ) = (shift, shift);
306 local $SIG{HUP} = 'IGNORE';
307 local $SIG{INT} = 'IGNORE';
308 local $SIG{QUIT} = 'IGNORE';
309 local $SIG{TERM} = 'IGNORE';
310 local $SIG{TSTP} = 'IGNORE';
311 local $SIG{PIPE} = 'IGNORE';
313 my $oldAutoCommit = $FS::UID::AutoCommit;
314 local $FS::UID::AutoCommit = 0;
317 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'insert',
318 'check', $self->export_username($svc_x), $self->radius_check($svc_x) );
319 unless ( ref($err_or_queue) ) {
320 $dbh->rollback if $oldAutoCommit;
321 return $err_or_queue;
325 my (@oldgroups) = $self->suspended_usergroups($svc_x);
326 $error = $self->sqlreplace_usergroups(
328 $self->export_username($svc_x),
331 [ $svc_x->radius_groups('hashref') ],
334 $dbh->rollback if $oldAutoCommit;
337 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
343 my( $self, $svc_x ) = (shift, shift);
344 my $usergroup = $self->option('usergroup') || 'usergroup';
345 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'delete',
346 $self->export_username($svc_x), $usergroup );
347 ref($err_or_queue) ? '' : $err_or_queue;
350 sub sqlradius_queue {
351 my( $self, $svcnum, $method ) = (shift, shift, shift);
353 my $queue = new FS::queue {
355 'job' => "FS::part_export::sqlradius::sqlradius_$method",
358 $self->option('datasrc'),
359 $self->option('username'),
360 $self->option('password'),
365 sub suspended_usergroups {
366 my ($self, $svc_x) = (shift, shift);
368 return () unless $svc_x;
370 my $svc_table = $svc_x->table;
372 #false laziness with FS::part_export::shellcommands
373 #subclass part_export?
375 my $r = $svc_x->cust_svc->cust_pkg->last_reason('susp');
376 my %reasonmap = $self->_groups_susp_reason_map;
379 $userspec = $reasonmap{$r->reasonnum}
380 if exists($reasonmap{$r->reasonnum});
381 $userspec = $reasonmap{$r->reason}
382 if (!$userspec && exists($reasonmap{$r->reason}));
385 if ( $userspec =~ /^\d+$/ ){
386 $suspend_svc = qsearchs( $svc_table, { 'svcnum' => $userspec } );
387 } elsif ( $userspec =~ /^\S+\@\S+$/ && $svc_table eq 'svc_acct' ){
388 my ($username,$domain) = split(/\@/, $userspec);
389 for my $user (qsearch( 'svc_acct', { 'username' => $username } )){
390 $suspend_svc = $user if $userspec eq $user->email;
392 }elsif ( $userspec && $svc_table eq 'svc_acct' ){
393 $suspend_svc = qsearchs( 'svc_acct', { 'username' => $userspec } );
396 return $suspend_svc->radius_groups('hashref') if $suspend_svc;
400 sub sqlradius_insert { #subroutine, not method
401 my $dbh = sqlradius_connect(shift, shift, shift);
402 my( $table, $username, %attributes ) = @_;
404 foreach my $attribute ( keys %attributes ) {
406 my $s_sth = $dbh->prepare(
407 "SELECT COUNT(*) FROM rad$table WHERE UserName = ? AND Attribute = ?"
408 ) or die $dbh->errstr;
409 $s_sth->execute( $username, $attribute ) or die $s_sth->errstr;
411 if ( $s_sth->fetchrow_arrayref->[0] ) {
413 my $u_sth = $dbh->prepare(
414 "UPDATE rad$table SET Value = ? WHERE UserName = ? AND Attribute = ?"
415 ) or die $dbh->errstr;
416 $u_sth->execute($attributes{$attribute}, $username, $attribute)
417 or die $u_sth->errstr;
421 my $i_sth = $dbh->prepare(
422 "INSERT INTO rad$table ( UserName, Attribute, op, Value ) ".
423 "VALUES ( ?, ?, ?, ? )"
424 ) or die $dbh->errstr;
428 ( $attribute eq 'Password' ? '==' : ':=' ),
429 $attributes{$attribute},
430 ) or die $i_sth->errstr;
438 sub sqlradius_usergroup_insert { #subroutine, not method
439 my $dbh = sqlradius_connect(shift, shift, shift);
440 my $username = shift;
441 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
444 my $s_sth = $dbh->prepare(
445 "SELECT COUNT(*) FROM $usergroup WHERE UserName = ? AND GroupName = ?"
446 ) or die $dbh->errstr;
448 my $sth = $dbh->prepare(
449 "INSERT INTO $usergroup ( UserName, GroupName, Priority ) VALUES ( ?, ?, ? )"
450 ) or die $dbh->errstr;
452 foreach ( @groups ) {
453 my $group = $_->{'groupname'};
454 my $priority = $_->{'priority'};
455 $s_sth->execute( $username, $group ) or die $s_sth->errstr;
456 if ($s_sth->fetchrow_arrayref->[0]) {
457 warn localtime() . ": sqlradius_usergroup_insert attempted to reinsert " .
458 "$group for $username\n"
462 $sth->execute( $username, $group, $priority )
463 or die "can't insert into groupname table: ". $sth->errstr;
465 if ( $s_sth->{Active} ) {
466 warn "sqlradius s_sth still active; calling ->finish()";
469 if ( $sth->{Active} ) {
470 warn "sqlradius sth still active; calling ->finish()";
476 sub sqlradius_usergroup_delete { #subroutine, not method
477 my $dbh = sqlradius_connect(shift, shift, shift);
478 my $username = shift;
479 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
482 my $sth = $dbh->prepare(
483 "DELETE FROM $usergroup WHERE UserName = ? AND GroupName = ?"
484 ) or die $dbh->errstr;
485 foreach ( @groups ) {
486 my $group = $_->{'groupname'};
487 $sth->execute( $username, $group )
488 or die "can't delete from groupname table: ". $sth->errstr;
493 sub sqlradius_rename { #subroutine, not method
494 my $dbh = sqlradius_connect(shift, shift, shift);
495 my($new_username, $old_username) = (shift, shift);
496 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
497 foreach my $table (qw(radreply radcheck), $usergroup ) {
498 my $sth = $dbh->prepare("UPDATE $table SET Username = ? WHERE UserName = ?")
500 $sth->execute($new_username, $old_username)
501 or die "can't update $table: ". $sth->errstr;
506 sub sqlradius_attrib_delete { #subroutine, not method
507 my $dbh = sqlradius_connect(shift, shift, shift);
508 my( $table, $username, @attrib ) = @_;
510 foreach my $attribute ( @attrib ) {
511 my $sth = $dbh->prepare(
512 "DELETE FROM rad$table WHERE UserName = ? AND Attribute = ?" )
514 $sth->execute($username,$attribute)
515 or die "can't delete from rad$table table: ". $sth->errstr;
520 sub sqlradius_delete { #subroutine, not method
521 my $dbh = sqlradius_connect(shift, shift, shift);
522 my $username = shift;
523 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
525 foreach my $table (qw( radcheck radreply), $usergroup ) {
526 my $sth = $dbh->prepare( "DELETE FROM $table WHERE UserName = ?" );
527 $sth->execute($username)
528 or die "can't delete from $table table: ". $sth->errstr;
533 sub sqlradius_connect {
534 #my($datasrc, $username, $password) = @_;
535 #DBI->connect($datasrc, $username, $password) or die $DBI::errstr;
536 DBI->connect(@_) or die $DBI::errstr;
539 sub sqlreplace_usergroups {
540 my ($self, $svcnum, $username, $jobnum, $old, $new) = @_;
542 # (sorta) false laziness with FS::svc_acct::replace
543 my @oldgroups = @$old;
544 my @newgroups = @$new;
546 foreach my $oldgroup ( @oldgroups ) {
547 if ( grep { $oldgroup eq $_ } @newgroups ) {
548 @newgroups = grep { $oldgroup ne $_ } @newgroups;
551 push @delgroups, $oldgroup;
554 my $usergroup = $self->option('usergroup') || 'usergroup';
557 my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_delete',
558 $username, $usergroup, @delgroups );
560 unless ref($err_or_queue);
562 my $error = $err_or_queue->depend_insert( $jobnum );
563 return $error if $error;
565 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
569 cluck localtime(). ": queuing usergroup_insert for $svcnum ($username) ".
570 "with ". join(", ", @newgroups)
572 my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_insert',
573 $username, $usergroup, @newgroups );
575 unless ref($err_or_queue);
577 my $error = $err_or_queue->depend_insert( $jobnum );
578 return $error if $error;
587 =item usage_sessions HASHREF
589 =item usage_sessions TIMESTAMP_START TIMESTAMP_END [ SVC_ACCT [ IP [ PREFIX [ SQL_SELECT ] ] ] ]
591 New-style: pass a hashref with the following keys:
595 =item stoptime_start - Lower bound for AcctStopTime, as a UNIX timestamp
597 =item stoptime_end - Upper bound for AcctStopTime, as a UNIX timestamp
599 =item open_sessions - Only show records with no AcctStopTime (typically used without stoptime_* options and with starttime_* options instead)
601 =item starttime_start - Lower bound for AcctStartTime, as a UNIX timestamp
603 =item starttime_end - Upper bound for AcctStartTime, as a UNIX timestamp
615 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
616 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
619 SVC_ACCT, if specified, limits the results to the specified account.
621 IP, if specified, limits the results to the specified IP address.
623 PREFIX, if specified, limits the results to records with a matching
626 #SQL_SELECT defaults to * if unspecified. It can be useful to set it to
627 #SUM(acctsessiontime) or SUM(AcctInputOctets), etc.
629 Returns an arrayref of hashrefs with the following fields:
635 =item framedipaddress
641 =item acctsessiontime
643 =item acctinputoctets
645 =item acctoutputoctets
647 =item calledstationid
653 #some false laziness w/cust_svc::seconds_since_sqlradacct
659 my($start, $end, $svc_acct, $ip, $prefix) = ( '', '', '', '', '');
663 $start = $opt->{stoptime_start};
664 $end = $opt->{stoptime_end};
665 $svc_acct = $opt->{svc_acct};
667 $prefix = $opt->{prefix};
668 $summarize = $opt->{summarize};
670 ( $start, $end ) = splice(@_, 0, 2);
671 $svc_acct = @_ ? shift : '';
672 $ip = @_ ? shift : '';
673 $prefix = @_ ? shift : '';
674 #my $select = @_ ? shift : '*';
679 return [] if $self->option('ignore_accounting');
681 my $dbh = sqlradius_connect( map $self->option($_),
682 qw( datasrc username password ) );
684 #select a unix time conversion function based on database type
685 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
688 qw( username realm framedipaddress
689 acctsessiontime acctinputoctets acctoutputoctets
692 "$str2time acctstarttime ) as acctstarttime",
693 "$str2time acctstoptime ) as acctstoptime",
696 @fields = ( 'username', 'sum(acctsessiontime) as acctsessiontime', 'sum(acctinputoctets) as acctinputoctets',
697 'sum(acctoutputoctets) as acctoutputoctets',
704 my $username = $self->export_username($svc_acct);
705 if ( $username =~ /^([^@]+)\@([^@]+)$/ ) {
706 push @where, '( UserName = ? OR ( UserName = ? AND Realm = ? ) )';
707 push @param, $username, $1, $2;
709 push @where, 'UserName = ?';
710 push @param, $username;
714 if ($self->option('process_single_realm')) {
715 push @where, 'Realm = ?';
716 push @param, $self->option('realm');
720 push @where, ' FramedIPAddress = ?';
724 if ( length($prefix) ) {
725 #assume sip: for now, else things get ugly trying to match /^\w+:$prefix/
726 push @where, " CalledStationID LIKE 'sip:$prefix\%'";
729 if ( $opt->{open_sessions} ) {
730 push @where, 'AcctStopTime IS NULL';
734 push @where, "$str2time AcctStopTime ) >= ?";
738 push @where, "$str2time AcctStopTime ) <= ?";
744 if ( $opt->{starttime_start} ) {
745 push @where, "$str2time AcctStartTime ) >= ?";
746 push @param, $opt->{starttime_start};
748 if ( $opt->{starttime_end} ) {
749 push @where, "$str2time AcctStartTime ) <= ?";
750 push @param, $opt->{starttime_end};
753 my $where = join(' AND ', @where);
754 $where = "WHERE $where" if $where;
757 $groupby = 'GROUP BY username' if $summarize;
759 my $orderby = 'ORDER BY AcctStartTime DESC';
760 $orderby = '' if $summarize;
762 my $sql = 'SELECT '. join(', ', @fields).
763 " FROM radacct $where $groupby $orderby";
766 warn join(',', @param);
768 my $sth = $dbh->prepare($sql) or die $dbh->errstr;
769 $sth->execute(@param) or die $sth->errstr;
771 [ map { { %$_ } } @{ $sth->fetchall_arrayref({}) } ];
782 my $conf = new FS::Conf;
785 my $dbh = sqlradius_connect( map $self->option($_),
786 qw( datasrc username password ) );
788 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
789 my @fields = qw( radacctid username realm acctsessiontime );
794 my $sth = $dbh->prepare("
795 SELECT RadAcctId, UserName, Realm, AcctSessionTime,
796 $str2time AcctStartTime), $str2time AcctStopTime),
797 AcctInputOctets, AcctOutputOctets
799 WHERE FreesideStatus IS NULL
800 AND AcctStopTime IS NOT NULL
801 ") or die $dbh->errstr;
802 $sth->execute() or die $sth->errstr;
804 while ( my $row = $sth->fetchrow_arrayref ) {
805 my($RadAcctId, $UserName, $Realm, $AcctSessionTime, $AcctStartTime,
806 $AcctStopTime, $AcctInputOctets, $AcctOutputOctets) = @$row;
807 warn "processing record: ".
808 "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s"
811 my $fs_username = $UserName;
813 $fs_username = lc($fs_username) unless $conf->exists('username-uppercase');
815 #my %search = ( 'username' => $UserName );
818 my $errinfo = "for RADIUS detail RadAcctID $RadAcctId ".
819 "(UserName $UserName, Realm $Realm)";
822 if ( ref($self) =~ /withdomain/ ) { #well, should be a callback to that
827 } elsif ( $fs_username =~ /\@/ ) {
828 ($fs_username, $domain) = split('@', $fs_username);
830 warn 'WARNING: nothing Realm column and no @realm in UserName column '.
831 "$errinfo -- skipping\n" if $DEBUG;
832 $status = 'skipped (no realm)';
835 $extra_sql = " AND '$domain' = ( SELECT domain FROM svc_domain
836 WHERE svc_domain.svcnum = svc_acct.domsvc ) ";
839 my $oldAutoCommit = $FS::UID::AutoCommit; # can't undo side effects, but at
840 local $FS::UID::AutoCommit = 0; # least we can avoid over counting
846 if ( $self->option('process_single_realm')
847 && $self->option('realm') ne $Realm )
849 warn "WARNING: wrong realm $errinfo - skipping\n" if $DEBUG;
852 grep { qsearch( 'export_svc', { 'exportnum' => $self->exportnum,
853 'svcpart' => $_->cust_svc->svcpart,
858 { 'username' => $fs_username },
864 warn "WARNING: no svc_acct record found $errinfo - skipping\n";
865 } elsif ( scalar(@svc_acct) > 1 ) {
866 warn "WARNING: multiple svc_acct records found $errinfo - skipping\n";
869 my $svc_acct = $svc_acct[0];
870 warn "found svc_acct ". $svc_acct->svcnum. " $errinfo\n" if $DEBUG;
872 $svc_acct->last_login($AcctStartTime);
873 $svc_acct->last_logout($AcctStopTime);
875 my $session_time = $AcctStopTime;
876 $session_time = $AcctStartTime
877 if $self->option('ignore_long_sessions');
879 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
880 if ( $cust_pkg && $session_time < ( $cust_pkg->last_bill
881 || $cust_pkg->setup ) ) {
882 $status = 'skipped (too old)';
885 push @st, _try_decrement($svc_acct,'seconds', $AcctSessionTime);
886 push @st, _try_decrement($svc_acct,'upbytes', $AcctInputOctets);
887 push @st, _try_decrement($svc_acct,'downbytes', $AcctOutputOctets);
888 push @st, _try_decrement($svc_acct,'totalbytes', $AcctInputOctets
889 + $AcctOutputOctets);
890 $status=join(' ', @st);
897 warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG;
898 my $psth = $dbh->prepare("UPDATE radacct
899 SET FreesideStatus = ?
901 ) or die $dbh->errstr;
902 $psth->execute($status, $RadAcctId) or die $psth->errstr;
904 $fdbh->commit or die $fdbh->errstr if $oldAutoCommit;
911 my ($svc_acct, $column, $amount) = @_;
912 if ( $svc_acct->$column !~ /^$/ ) {
913 warn " svc_acct.$column found (". $svc_acct->$column.
916 my $method = 'decrement_' . $column;
917 my $error = $svc_acct->$method($amount);
918 die $error if $error;
921 warn " no existing $column value for svc_acct - skipping\n" if $DEBUG;
926 =item export_nas_insert NAS
928 =item export_nas_delete NAS
930 =item export_nas_replace NEW_NAS OLD_NAS
932 Update the NAS table (allowed RADIUS clients) on the attached RADIUS
933 server. Currently requires the table to be named 'nas' and to follow
934 the stock schema (/etc/freeradius/nas.sql).
938 sub export_nas_insert { shift->export_nas_action('insert', @_); }
939 sub export_nas_delete { shift->export_nas_action('delete', @_); }
940 sub export_nas_replace { shift->export_nas_action('replace', @_); }
942 sub export_nas_action {
944 my ($action, $new, $old) = @_;
945 # find the NAS in the target table by its name
946 my $nasname = ($action eq 'replace') ? $old->nasname : $new->nasname;
947 my $nasnum = $new->nasnum;
949 my $err_or_queue = $self->sqlradius_queue('', "nas_$action",
953 return $err_or_queue unless ref $err_or_queue;
957 sub sqlradius_nas_insert {
958 my $dbh = sqlradius_connect(shift, shift, shift);
960 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
961 or die "nasnum ".$opt{'nasnum'}.' not found';
962 # insert actual NULLs where FS::Record has translated to empty strings
963 my @values = map { length($nas->$_) ? $nas->$_ : undef }
964 qw( nasname shortname type secret server community description );
965 my $sth = $dbh->prepare('INSERT INTO nas
966 (nasname, shortname, type, secret, server, community, description)
967 VALUES (?, ?, ?, ?, ?, ?, ?)');
968 $sth->execute(@values) or die $dbh->errstr;
971 sub sqlradius_nas_delete {
972 my $dbh = sqlradius_connect(shift, shift, shift);
974 my $sth = $dbh->prepare('DELETE FROM nas WHERE nasname = ?');
975 $sth->execute($opt{'nasname'}) or die $dbh->errstr;
978 sub sqlradius_nas_replace {
979 my $dbh = sqlradius_connect(shift, shift, shift);
981 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
982 or die "nasnum ".$opt{'nasnum'}.' not found';
983 my @values = map {$nas->$_}
984 qw( nasname shortname type secret server community description );
985 my $sth = $dbh->prepare('UPDATE nas SET
986 nasname = ?, shortname = ?, type = ?, secret = ?,
987 server = ?, community = ?, description = ?
989 $sth->execute(@values, $opt{'nasname'}) or die $dbh->errstr;
992 =item export_attr_insert RADIUS_ATTR
994 =item export_attr_delete RADIUS_ATTR
996 =item export_attr_replace NEW_RADIUS_ATTR OLD_RADIUS_ATTR
998 Update the group attribute tables (radgroupcheck and radgroupreply) on
999 the RADIUS server. In delete and replace actions, the existing records
1000 are identified by the combination of group name and attribute name.
1002 In the special case where attributes are being replaced because a group
1003 name (L<FS::radius_group>->groupname) is changing, the pseudo-field
1004 'groupname' must be set in OLD_RADIUS_ATTR.
1008 # some false laziness with NAS export stuff...
1010 sub export_attr_insert { shift->export_attr_action('insert', @_); }
1012 sub export_attr_delete { shift->export_attr_action('delete', @_); }
1014 sub export_attr_replace { shift->export_attr_action('replace', @_); }
1016 sub export_attr_action {
1018 my ($action, $new, $old) = @_;
1021 if ( $action eq 'delete' ) {
1024 if ( $action eq 'delete' or $action eq 'replace' ) {
1025 # delete based on an exact match
1027 attrname => $old->attrname,
1028 attrtype => $old->attrtype,
1029 groupname => $old->groupname || $old->radius_group->groupname,
1031 value => $old->value,
1033 $err_or_queue = $self->sqlradius_queue('', 'attr_delete', %opt);
1034 return $err_or_queue unless ref $err_or_queue;
1036 # this probably doesn't matter, but just to be safe...
1037 my $jobnum = $err_or_queue->jobnum if $action eq 'replace';
1038 if ( $action eq 'replace' or $action eq 'insert' ) {
1040 attrname => $new->attrname,
1041 attrtype => $new->attrtype,
1042 groupname => $new->radius_group->groupname,
1044 value => $new->value,
1046 $err_or_queue = $self->sqlradius_queue('', 'attr_insert', %opt);
1047 $err_or_queue->depend_insert($jobnum) if $jobnum;
1048 return $err_or_queue unless ref $err_or_queue;
1053 sub sqlradius_attr_insert {
1054 my $dbh = sqlradius_connect(shift, shift, shift);
1058 # make sure $table is completely safe
1059 if ( $opt{'attrtype'} eq 'C' ) {
1060 $table = 'radgroupcheck';
1062 elsif ( $opt{'attrtype'} eq 'R' ) {
1063 $table = 'radgroupreply';
1066 die "unknown attribute type '$opt{attrtype}'";
1069 my @values = @opt{ qw(groupname attrname op value) };
1070 my $sth = $dbh->prepare(
1071 'INSERT INTO '.$table.' (groupname, attribute, op, value) VALUES (?,?,?,?)'
1073 $sth->execute(@values) or die $dbh->errstr;
1076 sub sqlradius_attr_delete {
1077 my $dbh = sqlradius_connect(shift, shift, shift);
1081 if ( $opt{'attrtype'} eq 'C' ) {
1082 $table = 'radgroupcheck';
1084 elsif ( $opt{'attrtype'} eq 'R' ) {
1085 $table = 'radgroupreply';
1088 die "unknown attribute type '".$opt{'attrtype'}."'";
1091 my @values = @opt{ qw(groupname attrname op value) };
1092 my $sth = $dbh->prepare(
1093 'DELETE FROM '.$table.
1094 ' WHERE groupname = ? AND attribute = ? AND op = ? AND value = ?'.
1097 $sth->execute(@values) or die $dbh->errstr;
1100 #sub sqlradius_attr_replace { no longer needed
1102 =item export_group_replace NEW OLD
1104 Replace the L<FS::radius_group> object OLD with NEW. This will change
1105 the group name and priority in all radusergroup records, and the group
1106 name in radgroupcheck and radgroupreply.
1110 sub export_group_replace {
1112 my ($new, $old) = @_;
1113 return '' if $new->groupname eq $old->groupname
1114 and $new->priority == $old->priority;
1116 my $err_or_queue = $self->sqlradius_queue(
1119 ($self->option('usergroup') || 'usergroup'),
1123 return $err_or_queue unless ref $err_or_queue;
1127 sub sqlradius_group_replace {
1128 my $dbh = sqlradius_connect(shift, shift, shift);
1129 my $usergroup = shift;
1130 $usergroup =~ /^(rad)?usergroup$/
1131 or die "bad usergroup table name: $usergroup";
1132 my ($new, $old) = (shift, shift);
1133 # apply renames to check/reply attribute tables
1134 if ( $new->{'groupname'} ne $old->{'groupname'} ) {
1135 foreach my $table (qw(radgroupcheck radgroupreply)) {
1136 my $sth = $dbh->prepare(
1137 'UPDATE '.$table.' SET groupname = ? WHERE groupname = ?'
1139 $sth->execute($new->{'groupname'}, $old->{'groupname'})
1140 or die $dbh->errstr;
1143 # apply renames and priority changes to usergroup table
1144 my $sth = $dbh->prepare(
1145 'UPDATE '.$usergroup.' SET groupname = ?, priority = ? WHERE groupname = ?'
1147 $sth->execute($new->{'groupname'}, $new->{'priority'}, $old->{'groupname'})
1148 or die $dbh->errstr;
1152 # class method to fetch groups/attributes from the sqlradius install on upgrade
1155 sub _upgrade_exporttype {
1156 # do this only if the radius_attr table is empty
1157 local $FS::radius_attr::noexport_hack = 1;
1159 return if qsearch('radius_attr', {});
1161 foreach my $self ($class->all_sqlradius) {
1162 my $error = $self->import_attrs;
1163 die "exportnum ".$self->exportnum.":\n$error\n" if $error;
1170 my $dbh = DBI->connect( map $self->option($_),
1171 qw( datasrc username password ) );
1173 warn "Error connecting to RADIUS server: $DBI::errstr\n";
1177 my $usergroup = $self->option('usergroup') || 'usergroup';
1179 warn "Importing RADIUS groups and attributes from ".$self->option('datasrc').
1182 # map out existing groups and attrs
1185 foreach my $radius_group ( qsearch('radius_group', {}) ) {
1186 $attrs_of{$radius_group->groupname} = +{
1187 map { $_->attrname => $_ } $radius_group->radius_attr
1189 $groupnum_of{$radius_group->groupname} = $radius_group->groupnum;
1192 # get groupnames from radgroupcheck and radgroupreply
1194 SELECT groupname, attribute, op, value, \'C\' FROM radgroupcheck
1196 SELECT groupname, attribute, op, value, \'R\' FROM radgroupreply';
1197 my @fixes; # things that need to be changed on the radius db
1198 foreach my $row ( @{ $dbh->selectall_arrayref($sql) } ) {
1199 my ($groupname, $attrname, $op, $value, $attrtype) = @$row;
1200 warn "$groupname.$attrname\n";
1201 if ( !exists($groupnum_of{$groupname}) ) {
1202 my $radius_group = new FS::radius_group {
1203 'groupname' => $groupname,
1206 $error = $radius_group->insert;
1208 warn "error inserting group $groupname: $error";
1209 next;#don't continue trying to insert the attribute
1211 $attrs_of{$groupname} = {};
1212 $groupnum_of{$groupname} = $radius_group->groupnum;
1215 my $a = $attrs_of{$groupname};
1216 my $old = $a->{$attrname};
1219 if ( $attrtype eq 'R' ) {
1220 # Freeradius tolerates illegal operators in reply attributes. We don't.
1221 if ( !grep ($_ eq $op, FS::radius_attr->ops('R')) ) {
1222 warn "$groupname.$attrname: changing $op to +=\n";
1223 # Make a note to change it in the db
1225 'UPDATE radgroupreply SET op = \'+=\' WHERE groupname = ? AND attribute = ? AND op = ? AND VALUE = ?',
1226 $groupname, $attrname, $op, $value
1228 # and import it correctly.
1233 if ( defined $old ) {
1235 $new = new FS::radius_attr {
1240 $error = $new->replace($old);
1242 warn "error modifying attr $attrname: $error";
1247 $new = new FS::radius_attr {
1248 'groupnum' => $groupnum_of{$groupname},
1249 'attrname' => $attrname,
1250 'attrtype' => $attrtype,
1254 $error = $new->insert;
1256 warn "error inserting attr $attrname: $error" if $error;
1260 $attrs_of{$groupname}->{$attrname} = $new;
1264 my ($sql, @args) = @$_;
1265 my $sth = $dbh->prepare($sql);
1266 $sth->execute(@args) or warn $sth->errstr;
1279 #don't just look for ->can('usage_sessions'), we're sqlradius-specific
1280 # (radiator is supposed to be setup with a radacct table)
1281 #i suppose it would be more slick to look for things that inherit from us..
1283 my @part_export = ();
1284 push @part_export, qsearch('part_export', { 'exporttype' => $_ } )
1285 foreach qw( sqlradius sqlradius_withdomain radiator phone_sqlradius
1286 broadband_sqlradius );
1290 sub all_sqlradius_withaccounting {
1292 grep { ! $_->option('ignore_accounting') } $class->all_sqlradius;