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 str2time_sql_closing );
15 @ISA = qw(FS::part_export);
16 @EXPORT_OK = qw( sqlradius_connect );
21 tie %options, 'Tie::IxHash',
22 'datasrc' => { label=>'DBI data source ' },
23 'username' => { label=>'Database username' },
24 'password' => { label=>'Database password' },
25 'usergroup' => { label => 'Group table',
27 options => [qw( usergroup radusergroup ) ],
29 'ignore_accounting' => {
31 label => 'Ignore accounting records from this database'
33 'process_single_realm' => {
35 label => 'Only process one realm of accounting records',
37 'realm' => { label => 'The realm of of accounting records to be processed' },
38 'ignore_long_sessions' => {
40 label => 'Ignore sessions which span billing periods',
44 label => 'Hide IP address information on session reports',
48 label => 'Hide download/upload information on session reports',
50 'show_called_station' => {
52 label => 'Show the Called-Station-ID on session reports', #as a phone number
54 'overlimit_groups' => {
55 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 option_values => sub {
63 map { $_->groupnum, $_->long_description }
64 qsearch('radius_group', {}),
69 'groups_susp_reason' => { label =>
70 'Radius group mapping to reason (via template user) (svcnum|username|username@domain reasonnum|reason)',
75 label => 'Export RADIUS group attributes to this database',
78 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',
80 'disconnect_port' => {
81 label => 'Port to send disconnection requests to, default 1700',
83 'disconnect_ignore_error' => {
84 label => 'Ignore disconnection request errors',
90 Real-time export of <b>radcheck</b>, <b>radreply</b> and <b>usergroup</b>/<b>radusergroup</b>
91 tables to any SQL database for
92 <a href="http://www.freeradius.org/">FreeRADIUS</a>
93 or <a href="http://radius.innercite.com/">ICRADIUS</a>.
97 An existing RADIUS database will be updated in realtime, but you can use
98 <a href="http://www.freeside.biz/mediawiki/index.php/Freeside:1.9:Documentation:Developer/bin/freeside-sqlradius-reset">freeside-sqlradius-reset</a>
99 to delete the entire RADIUS database and repopulate the tables from the
100 Freeside database. See the
101 <a href="http://search.cpan.org/dist/DBI/DBI.pm#connect">DBI documentation</a>
103 <a href="http://search.cpan.org/search?mode=module&query=DBD%3A%3A">documentation for your DBD</a>
104 for the exact syntax of a DBI data source.
106 <li>Using FreeRADIUS 0.9.0 with the PostgreSQL backend, the db_postgresql.sql schema and postgresql.conf queries contain incompatible changes. This is fixed in 0.9.1. Only new installs with 0.9.0 and PostgreSQL are affected - upgrades and other database backends and versions are unaffected.
107 <li>Using ICRADIUS, add a dummy "op" column to your database:
109 ALTER TABLE radcheck ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='<br>
110 ALTER TABLE radreply ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='<br>
111 ALTER TABLE radgroupcheck ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='<br>
112 ALTER TABLE radgroupreply ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='
114 <li>Using Radiator, see the
115 <a href="http://www.open.com.au/radiator/faq.html#38">Radiator FAQ</a>
116 for configuration information.
122 'desc' => 'Real-time export to SQL-backed RADIUS (FreeRADIUS, ICRADIUS)',
123 'options' => \%options,
126 'nas' => 'Y', # show export_nas selection in UI
127 'default_svc_class' => 'Internet',
129 'This export does not export RADIUS realms (see also '.
130 'sqlradius_withdomain). '.
134 sub _groups_susp_reason_map { map { reverse( /^\s*(\S+)\s*(.*)$/ ) }
135 split( "\n", shift->option('groups_susp_reason'));
138 sub rebless { shift; }
140 sub export_username { # override for other svcdb
141 my($self, $svc_acct) = (shift, shift);
142 warn "export_username called on $self with arg $svc_acct" if $DEBUG > 1;
146 sub radius_reply { #override for other svcdb
147 my($self, $svc_acct) = (shift, shift);
148 my %every = $svc_acct->EVERY::radius_reply;
149 map { @$_ } values %every;
152 sub radius_check { #override for other svcdb
153 my($self, $svc_acct) = (shift, shift);
154 my %every = $svc_acct->EVERY::radius_check;
155 map { @$_ } values %every;
159 my($self, $svc_x) = (shift, shift);
161 foreach my $table (qw(reply check)) {
162 my $method = "radius_$table";
163 my %attrib = $self->$method($svc_x);
164 next unless keys %attrib;
165 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'insert',
166 $table, $self->export_username($svc_x), %attrib );
167 return $err_or_queue unless ref($err_or_queue);
169 my @groups = $svc_x->radius_groups('hashref');
171 cluck localtime(). ": queuing usergroup_insert for ". $svc_x->svcnum.
172 " (". $self->export_username($svc_x). " with ". join(", ", @groups)
174 my $usergroup = $self->option('usergroup') || 'usergroup';
175 my $err_or_queue = $self->sqlradius_queue(
176 $svc_x->svcnum, 'usergroup_insert',
177 $self->export_username($svc_x), $usergroup, @groups );
178 return $err_or_queue unless ref($err_or_queue);
183 sub _export_replace {
184 my( $self, $new, $old ) = (shift, shift, shift);
186 local $SIG{HUP} = 'IGNORE';
187 local $SIG{INT} = 'IGNORE';
188 local $SIG{QUIT} = 'IGNORE';
189 local $SIG{TERM} = 'IGNORE';
190 local $SIG{TSTP} = 'IGNORE';
191 local $SIG{PIPE} = 'IGNORE';
193 my $oldAutoCommit = $FS::UID::AutoCommit;
194 local $FS::UID::AutoCommit = 0;
198 if ( $self->export_username($old) ne $self->export_username($new) ) {
199 my $usergroup = $self->option('usergroup') || 'usergroup';
200 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'rename',
201 $self->export_username($new), $self->export_username($old), $usergroup );
202 unless ( ref($err_or_queue) ) {
203 $dbh->rollback if $oldAutoCommit;
204 return $err_or_queue;
206 $jobnum = $err_or_queue->jobnum;
209 foreach my $table (qw(reply check)) {
210 my $method = "radius_$table";
211 my %new = $self->$method($new);
212 my %old = $self->$method($old);
213 if ( grep { !exists $old{$_} #new attributes
214 || $new{$_} ne $old{$_} #changed
217 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
218 $table, $self->export_username($new), %new );
219 unless ( ref($err_or_queue) ) {
220 $dbh->rollback if $oldAutoCommit;
221 return $err_or_queue;
224 my $error = $err_or_queue->depend_insert( $jobnum );
226 $dbh->rollback if $oldAutoCommit;
230 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
233 my @del = grep { !exists $new{$_} } keys %old;
235 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'attrib_delete',
236 $table, $self->export_username($new), @del );
237 unless ( ref($err_or_queue) ) {
238 $dbh->rollback if $oldAutoCommit;
239 return $err_or_queue;
242 my $error = $err_or_queue->depend_insert( $jobnum );
244 $dbh->rollback if $oldAutoCommit;
248 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
253 my (@oldgroups) = $old->radius_groups('hashref');
254 my (@newgroups) = $new->radius_groups('hashref');
255 ($error,$jobnum) = $self->sqlreplace_usergroups( $new->svcnum,
256 $self->export_username($new),
257 $jobnum ? $jobnum : '',
262 $dbh->rollback if $oldAutoCommit;
266 # radius database is used for authorization, so to avoid users reauthorizing
267 # before the database changes, disconnect users after changing database
268 if ($self->option('disconnect_ssh')) {
269 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'user_disconnect',
270 'disconnect_ssh' => $self->option('disconnect_ssh'),
271 'svc_acct_username' => $old->username,
272 'disconnect_port' => $self->option('disconnect_port'),
273 'ignore_error' => $self->option('disconnect_ignore_error'),
275 unless ( ref($err_or_queue) ) {
276 $dbh->rollback if $oldAutoCommit;
277 return $err_or_queue;
280 my $error = $err_or_queue->depend_insert( $jobnum );
282 $dbh->rollback if $oldAutoCommit;
288 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
293 #false laziness w/broadband_sqlradius.pm
294 sub _export_suspend {
295 my( $self, $svc_acct ) = (shift, shift);
297 my $new = $svc_acct->clone_suspended;
299 local $SIG{HUP} = 'IGNORE';
300 local $SIG{INT} = 'IGNORE';
301 local $SIG{QUIT} = 'IGNORE';
302 local $SIG{TERM} = 'IGNORE';
303 local $SIG{TSTP} = 'IGNORE';
304 local $SIG{PIPE} = 'IGNORE';
306 my $oldAutoCommit = $FS::UID::AutoCommit;
307 local $FS::UID::AutoCommit = 0;
312 my @newgroups = $self->suspended_usergroups($svc_acct);
314 unless (@newgroups) { #don't change password if assigning to a suspended group
316 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
317 'check', $self->export_username($new), $new->radius_check );
318 unless ( ref($err_or_queue) ) {
319 $dbh->rollback if $oldAutoCommit;
320 return $err_or_queue;
322 $jobnum = $err_or_queue->jobnum;
327 $self->sqlreplace_usergroups(
329 $self->export_username($new),
331 [ $svc_acct->radius_groups('hashref') ],
335 $dbh->rollback if $oldAutoCommit;
339 # radius database is used for authorization, so to avoid users reauthorizing
340 # before the database changes, disconnect users after changing database
341 if ($self->option('disconnect_ssh')) {
342 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'user_disconnect',
343 'disconnect_ssh' => $self->option('disconnect_ssh'),
344 'svc_acct_username' => $svc_acct->username,
345 'disconnect_port' => $self->option('disconnect_port'),
347 unless ( ref($err_or_queue) ) {
348 $dbh->rollback if $oldAutoCommit;
349 return $err_or_queue;
352 my $error = $err_or_queue->depend_insert( $jobnum );
354 $dbh->rollback if $oldAutoCommit;
360 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
365 sub _export_unsuspend {
366 my( $self, $svc_x ) = (shift, shift);
368 local $SIG{HUP} = 'IGNORE';
369 local $SIG{INT} = 'IGNORE';
370 local $SIG{QUIT} = 'IGNORE';
371 local $SIG{TERM} = 'IGNORE';
372 local $SIG{TSTP} = 'IGNORE';
373 local $SIG{PIPE} = 'IGNORE';
375 my $oldAutoCommit = $FS::UID::AutoCommit;
376 local $FS::UID::AutoCommit = 0;
379 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'insert',
380 'check', $self->export_username($svc_x), $self->radius_check($svc_x) );
381 unless ( ref($err_or_queue) ) {
382 $dbh->rollback if $oldAutoCommit;
383 return $err_or_queue;
387 my (@oldgroups) = $self->suspended_usergroups($svc_x);
388 $error = $self->sqlreplace_usergroups(
390 $self->export_username($svc_x),
393 [ $svc_x->radius_groups('hashref') ],
396 $dbh->rollback if $oldAutoCommit;
399 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
405 my( $self, $svc_x ) = (shift, shift);
409 my $usergroup = $self->option('usergroup') || 'usergroup';
410 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'delete',
411 $self->export_username($svc_x), $usergroup );
412 $jobnum = $err_or_queue->jobnum;
414 # radius database is used for authorization, so to avoid users reauthorizing
415 # before the database changes, disconnect users after changing database
416 if ($self->option('disconnect_ssh')) {
417 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'user_disconnect',
418 'disconnect_ssh' => $self->option('disconnect_ssh'),
419 'svc_acct_username' => $svc_x->username,
420 'disconnect_port' => $self->option('disconnect_port'),
421 'ignore_error' => $self->option('disconnect_ignore_error'),
423 return $err_or_queue unless ref($err_or_queue);
425 my $error = $err_or_queue->depend_insert( $jobnum );
426 return $error if $error;
430 ref($err_or_queue) ? '' : $err_or_queue;
433 sub sqlradius_queue {
434 my( $self, $svcnum, $method ) = (shift, shift, shift);
436 my $queue = new FS::queue {
438 'job' => "FS::part_export::sqlradius::sqlradius_$method",
441 $self->option('datasrc'),
442 $self->option('username'),
443 $self->option('password'),
448 sub suspended_usergroups {
449 my ($self, $svc_x) = (shift, shift);
451 return () unless $svc_x;
453 my $svc_table = $svc_x->table;
455 #false laziness with FS::part_export::shellcommands
456 #subclass part_export?
458 my $r = $svc_x->cust_svc->cust_pkg->last_reason('susp');
459 my %reasonmap = $self->_groups_susp_reason_map;
462 $userspec = $reasonmap{$r->reasonnum}
463 if exists($reasonmap{$r->reasonnum});
464 $userspec = $reasonmap{$r->reason}
465 if (!$userspec && exists($reasonmap{$r->reason}));
468 if ( $userspec =~ /^\d+$/ ){
469 $suspend_svc = qsearchs( $svc_table, { 'svcnum' => $userspec } );
470 } elsif ( $userspec =~ /^\S+\@\S+$/ && $svc_table eq 'svc_acct' ){
471 my ($username,$domain) = split(/\@/, $userspec);
472 for my $user (qsearch( 'svc_acct', { 'username' => $username } )){
473 $suspend_svc = $user if $userspec eq $user->email;
475 }elsif ( $userspec && $svc_table eq 'svc_acct' ){
476 $suspend_svc = qsearchs( 'svc_acct', { 'username' => $userspec } );
479 return $suspend_svc->radius_groups('hashref') if $suspend_svc;
483 sub sqlradius_insert { #subroutine, not method
484 my $dbh = sqlradius_connect(shift, shift, shift);
485 my( $table, $username, %attributes ) = @_;
487 foreach my $attribute ( keys %attributes ) {
489 my $s_sth = $dbh->prepare(
490 "SELECT COUNT(*) FROM rad$table WHERE UserName = ? AND Attribute = ?"
491 ) or die $dbh->errstr;
492 $s_sth->execute( $username, $attribute ) or die $s_sth->errstr;
494 if ( $s_sth->fetchrow_arrayref->[0] ) {
496 my $u_sth = $dbh->prepare(
497 "UPDATE rad$table SET Value = ? WHERE UserName = ? AND Attribute = ?"
498 ) or die $dbh->errstr;
499 $u_sth->execute($attributes{$attribute}, $username, $attribute)
500 or die $u_sth->errstr;
504 my $i_sth = $dbh->prepare(
505 "INSERT INTO rad$table ( UserName, Attribute, op, Value ) ".
506 "VALUES ( ?, ?, ?, ? )"
507 ) or die $dbh->errstr;
511 ( $attribute eq 'Password' ? '==' : ':=' ),
512 $attributes{$attribute},
513 ) or die $i_sth->errstr;
521 sub sqlradius_usergroup_insert { #subroutine, not method
522 my $dbh = sqlradius_connect(shift, shift, shift);
523 my $username = shift;
524 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
527 my $s_sth = $dbh->prepare(
528 "SELECT COUNT(*) FROM $usergroup WHERE UserName = ? AND GroupName = ?"
529 ) or die $dbh->errstr;
531 my $sth = $dbh->prepare(
532 "INSERT INTO $usergroup ( UserName, GroupName, Priority ) VALUES ( ?, ?, ? )"
533 ) or die $dbh->errstr;
535 foreach ( @groups ) {
536 my $group = $_->{'groupname'};
537 my $priority = $_->{'priority'};
538 $s_sth->execute( $username, $group ) or die $s_sth->errstr;
539 if ($s_sth->fetchrow_arrayref->[0]) {
540 warn localtime() . ": sqlradius_usergroup_insert attempted to reinsert " .
541 "$group for $username\n"
545 $sth->execute( $username, $group, $priority )
546 or die "can't insert into groupname table: ". $sth->errstr;
548 if ( $s_sth->{Active} ) {
549 warn "sqlradius s_sth still active; calling ->finish()";
552 if ( $sth->{Active} ) {
553 warn "sqlradius sth still active; calling ->finish()";
559 sub sqlradius_usergroup_delete { #subroutine, not method
560 my $dbh = sqlradius_connect(shift, shift, shift);
561 my $username = shift;
562 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
565 my $sth = $dbh->prepare(
566 "DELETE FROM $usergroup WHERE UserName = ? AND GroupName = ?"
567 ) or die $dbh->errstr;
568 foreach ( @groups ) {
569 my $group = $_->{'groupname'};
570 $sth->execute( $username, $group )
571 or die "can't delete from groupname table: ". $sth->errstr;
576 sub sqlradius_rename { #subroutine, not method
577 my $dbh = sqlradius_connect(shift, shift, shift);
578 my($new_username, $old_username) = (shift, shift);
579 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
580 foreach my $table (qw(radreply radcheck), $usergroup ) {
581 my $sth = $dbh->prepare("UPDATE $table SET Username = ? WHERE UserName = ?")
583 $sth->execute($new_username, $old_username)
584 or die "can't update $table: ". $sth->errstr;
589 sub sqlradius_attrib_delete { #subroutine, not method
590 my $dbh = sqlradius_connect(shift, shift, shift);
591 my( $table, $username, @attrib ) = @_;
593 foreach my $attribute ( @attrib ) {
594 my $sth = $dbh->prepare(
595 "DELETE FROM rad$table WHERE UserName = ? AND Attribute = ?" )
597 $sth->execute($username,$attribute)
598 or die "can't delete from rad$table table: ". $sth->errstr;
603 sub sqlradius_delete { #subroutine, not method
604 my $dbh = sqlradius_connect(shift, shift, shift);
605 my $username = shift;
606 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
608 foreach my $table (qw( radcheck radreply), $usergroup ) {
609 my $sth = $dbh->prepare( "DELETE FROM $table WHERE UserName = ?" );
610 $sth->execute($username)
611 or die "can't delete from $table table: ". $sth->errstr;
616 sub sqlradius_connect {
617 #my($datasrc, $username, $password) = @_;
618 #DBI->connect($datasrc, $username, $password) or die $DBI::errstr;
619 DBI->connect(@_) or die $DBI::errstr;
622 # on success, returns '' in scalar context, ('',$jobnum) in list context
623 # on error, always just returns error
624 sub sqlreplace_usergroups {
625 my ($self, $svcnum, $username, $jobnum, $old, $new) = @_;
627 # (sorta) false laziness with FS::svc_acct::replace
628 my @oldgroups = @$old;
629 my @newgroups = @$new;
631 foreach my $oldgroup ( @oldgroups ) {
632 if ( grep { $oldgroup eq $_ } @newgroups ) {
633 @newgroups = grep { $oldgroup ne $_ } @newgroups;
636 push @delgroups, $oldgroup;
639 my $usergroup = $self->option('usergroup') || 'usergroup';
642 my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_delete',
643 $username, $usergroup, @delgroups );
645 unless ref($err_or_queue);
647 my $error = $err_or_queue->depend_insert( $jobnum );
648 return $error if $error;
650 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
654 cluck localtime(). ": queuing usergroup_insert for $svcnum ($username) ".
655 "with ". join(", ", @newgroups)
657 my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_insert',
658 $username, $usergroup, @newgroups );
660 unless ref($err_or_queue);
662 my $error = $err_or_queue->depend_insert( $jobnum );
663 return $error if $error;
665 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
667 wantarray ? ('',$jobnum) : '';
673 =item usage_sessions HASHREF
675 =item usage_sessions TIMESTAMP_START TIMESTAMP_END [ SVC_ACCT [ IP [ PREFIX [ SQL_SELECT ] ] ] ]
677 New-style: pass a hashref with the following keys:
681 =item stoptime_start - Lower bound for AcctStopTime, as a UNIX timestamp
683 =item stoptime_end - Upper bound for AcctStopTime, as a UNIX timestamp
685 =item session_status - 'closed' to only show records with AcctStopTime,
686 'open' to only show records I<without> AcctStopTime, empty to show both.
688 =item starttime_start - Lower bound for AcctStartTime, as a UNIX timestamp
690 =item starttime_end - Upper bound for AcctStartTime, as a UNIX timestamp
702 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
703 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
706 SVC_ACCT, if specified, limits the results to the specified account.
708 IP, if specified, limits the results to the specified IP address.
710 PREFIX, if specified, limits the results to records with a matching
713 #SQL_SELECT defaults to * if unspecified. It can be useful to set it to
714 #SUM(acctsessiontime) or SUM(AcctInputOctets), etc.
716 Returns an arrayref of hashrefs with the following fields:
722 =item framedipaddress
728 =item acctsessiontime
730 =item acctinputoctets
732 =item acctoutputoctets
734 =item callingstationid
736 =item calledstationid
742 #some false laziness w/cust_svc::seconds_since_sqlradacct
748 my($start, $end, $svc_acct, $ip, $prefix) = ( '', '', '', '', '');
752 $start = $opt->{stoptime_start};
753 $end = $opt->{stoptime_end};
754 $svc_acct = $opt->{svc} || $opt->{svc_acct};
756 $prefix = $opt->{prefix};
757 $summarize = $opt->{summarize};
759 ( $start, $end ) = splice(@_, 0, 2);
760 $svc_acct = @_ ? shift : '';
761 $ip = @_ ? shift : '';
762 $prefix = @_ ? shift : '';
763 #my $select = @_ ? shift : '*';
768 return [] if $self->option('ignore_accounting');
770 my $dbh = sqlradius_connect( map $self->option($_),
771 qw( datasrc username password ) );
773 #select a unix time conversion function based on database type
774 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
775 my $closing = str2time_sql_closing( $dbh->{Driver}->{Name} );
778 qw( username realm framedipaddress
779 acctsessiontime acctinputoctets acctoutputoctets
780 callingstationid calledstationid
782 "$str2time acctstarttime $closing as acctstarttime",
783 "$str2time acctstoptime $closing as acctstoptime",
786 @fields = ( 'username', 'sum(acctsessiontime) as acctsessiontime', 'sum(acctinputoctets) as acctinputoctets',
787 'sum(acctoutputoctets) as acctoutputoctets',
794 my $username = $self->export_username($svc_acct);
795 if ( $username =~ /^([^@]+)\@([^@]+)$/ ) {
796 push @where, '( UserName = ? OR ( UserName = ? AND Realm = ? ) )';
797 push @param, $username, $1, $2;
799 push @where, 'UserName = ?';
800 push @param, $username;
804 if ($self->option('process_single_realm')) {
805 push @where, 'Realm = ?';
806 push @param, $self->option('realm');
810 push @where, ' FramedIPAddress = ?';
814 if ( length($prefix) ) {
815 #assume sip: for now, else things get ugly trying to match /^\w+:$prefix/
816 push @where, " CalledStationID LIKE 'sip:$prefix\%'";
819 my $acctstoptime = '';
820 if ( $opt->{session_status} ne 'open' ) {
822 $acctstoptime .= "$str2time AcctStopTime $closing >= ?";
824 $acctstoptime .= ' AND ' if $end;
827 $acctstoptime .= "$str2time AcctStopTime $closing <= ?";
831 if ( $opt->{session_status} ne 'closed' ) {
832 if ( $acctstoptime ) {
833 $acctstoptime = "( ( $acctstoptime ) OR AcctStopTime IS NULL )";
835 $acctstoptime = 'AcctStopTime IS NULL';
838 push @where, $acctstoptime;
840 if ( $opt->{starttime_start} ) {
841 push @where, "$str2time AcctStartTime $closing >= ?";
842 push @param, $opt->{starttime_start};
844 if ( $opt->{starttime_end} ) {
845 push @where, "$str2time AcctStartTime $closing <= ?";
846 push @param, $opt->{starttime_end};
849 my $where = join(' AND ', @where);
850 $where = "WHERE $where" if $where;
853 $groupby = 'GROUP BY username' if $summarize;
855 my $orderby = 'ORDER BY AcctStartTime DESC';
856 $orderby = '' if $summarize;
858 my $sql = 'SELECT '. join(', ', @fields).
859 " FROM radacct $where $groupby $orderby";
862 warn join(',', @param);
864 my $sth = $dbh->prepare($sql) or die $dbh->errstr;
865 $sth->execute(@param) or die $sth->errstr;
867 [ map { { %$_ } } @{ $sth->fetchall_arrayref({}) } ];
878 my $conf = new FS::Conf;
881 my $dbh = sqlradius_connect( map $self->option($_),
882 qw( datasrc username password ) );
884 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
885 my $closing = str2time_sql_closing( $dbh->{Driver}->{Name} );
887 my @fields = qw( radacctid username realm acctsessiontime );
892 my $sth = $dbh->prepare("
893 SELECT RadAcctId, UserName, Realm, AcctSessionTime,
894 $str2time AcctStartTime $closing, $str2time AcctStopTime $closing,
895 AcctInputOctets, AcctOutputOctets
897 WHERE FreesideStatus IS NULL
898 AND AcctStopTime IS NOT NULL
899 ") or die $dbh->errstr;
900 $sth->execute() or die $sth->errstr;
902 while ( my $row = $sth->fetchrow_arrayref ) {
903 my($RadAcctId, $UserName, $Realm, $AcctSessionTime, $AcctStartTime,
904 $AcctStopTime, $AcctInputOctets, $AcctOutputOctets) = @$row;
905 warn "processing record: ".
906 "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s"
909 my $fs_username = $UserName;
911 $fs_username = lc($fs_username) unless $conf->exists('username-uppercase');
913 #my %search = ( 'username' => $fs_username );
916 my $errinfo = "for RADIUS detail RadAcctID $RadAcctId ".
917 "(UserName $UserName, Realm $Realm)";
920 if ( ref($self) =~ /withdomain/ ) { #well, should be a callback to that
925 } elsif ( $fs_username =~ /\@/ ) {
926 ($fs_username, $domain) = split('@', $fs_username);
928 warn 'WARNING: nothing Realm column and no @realm in UserName column '.
929 "$errinfo -- skipping\n" if $DEBUG;
930 $status = 'skipped (no realm)';
933 $extra_sql = " AND '$domain' = ( SELECT domain FROM svc_domain
934 WHERE svc_domain.svcnum = svc_acct.domsvc ) ";
937 my $oldAutoCommit = $FS::UID::AutoCommit; # can't undo side effects, but at
938 local $FS::UID::AutoCommit = 0; # least we can avoid over counting
944 if ( $self->option('process_single_realm')
945 && $self->option('realm') ne $Realm )
947 warn "WARNING: wrong realm $errinfo - skipping\n" if $DEBUG;
950 grep { qsearch( 'export_svc', { 'exportnum' => $self->exportnum,
951 'svcpart' => $_->cust_svc->svcpart,
956 { 'username' => $fs_username },
962 warn "WARNING: no svc_acct record found $errinfo - skipping\n";
963 } elsif ( scalar(@svc_acct) > 1 ) {
964 warn "WARNING: multiple svc_acct records found $errinfo - skipping\n";
967 my $svc_acct = $svc_acct[0];
968 warn "found svc_acct ". $svc_acct->svcnum. " $errinfo\n" if $DEBUG;
970 $svc_acct->last_login($AcctStartTime);
971 $svc_acct->last_logout($AcctStopTime);
973 my $session_time = $AcctStopTime;
974 $session_time = $AcctStartTime
975 if $self->option('ignore_long_sessions');
977 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
978 if ( $cust_pkg && $session_time < ( $cust_pkg->last_bill
979 || $cust_pkg->setup ) ) {
980 $status = 'skipped (too old)';
983 push @st, _try_decrement($svc_acct,'seconds', $AcctSessionTime);
984 push @st, _try_decrement($svc_acct,'upbytes', $AcctInputOctets);
985 push @st, _try_decrement($svc_acct,'downbytes', $AcctOutputOctets);
986 push @st, _try_decrement($svc_acct,'totalbytes', $AcctInputOctets
987 + $AcctOutputOctets);
988 $status=join(' ', @st);
995 warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG;
996 my $psth = $dbh->prepare("UPDATE radacct
997 SET FreesideStatus = ?
999 ) or die $dbh->errstr;
1000 $psth->execute($status, $RadAcctId) or die $psth->errstr;
1002 $fdbh->commit or die $fdbh->errstr if $oldAutoCommit;
1008 sub _try_decrement {
1009 my ($svc_acct, $column, $amount) = @_;
1010 if ( $svc_acct->$column !~ /^$/ ) {
1011 warn " svc_acct.$column found (". $svc_acct->$column.
1012 ") - decrementing\n"
1014 my $method = 'decrement_' . $column;
1015 my $error = $svc_acct->$method($amount);
1016 die $error if $error;
1019 warn " no existing $column value for svc_acct - skipping\n" if $DEBUG;
1024 =item export_nas_insert NAS
1026 =item export_nas_delete NAS
1028 =item export_nas_replace NEW_NAS OLD_NAS
1030 Update the NAS table (allowed RADIUS clients) on the attached RADIUS
1031 server. Currently requires the table to be named 'nas' and to follow
1032 the stock schema (/etc/freeradius/nas.sql).
1036 sub export_nas_insert { shift->export_nas_action('insert', @_); }
1037 sub export_nas_delete { shift->export_nas_action('delete', @_); }
1038 sub export_nas_replace { shift->export_nas_action('replace', @_); }
1040 sub export_nas_action {
1042 my ($action, $new, $old) = @_;
1043 # find the NAS in the target table by its name
1044 my $nasname = ($action eq 'replace') ? $old->nasname : $new->nasname;
1045 my $nasnum = $new->nasnum;
1047 my $err_or_queue = $self->sqlradius_queue('', "nas_$action",
1048 nasname => $nasname,
1051 return $err_or_queue unless ref $err_or_queue;
1055 sub sqlradius_nas_insert {
1056 my $dbh = sqlradius_connect(shift, shift, shift);
1058 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
1059 or die "nasnum ".$opt{'nasnum'}.' not found';
1060 # insert actual NULLs where FS::Record has translated to empty strings
1061 my @values = map { length($nas->$_) ? $nas->$_ : undef }
1062 qw( nasname shortname type secret server community description );
1063 my $sth = $dbh->prepare('INSERT INTO nas
1064 (nasname, shortname, type, secret, server, community, description)
1065 VALUES (?, ?, ?, ?, ?, ?, ?)');
1066 $sth->execute(@values) or die $dbh->errstr;
1069 sub sqlradius_nas_delete {
1070 my $dbh = sqlradius_connect(shift, shift, shift);
1072 my $sth = $dbh->prepare('DELETE FROM nas WHERE nasname = ?');
1073 $sth->execute($opt{'nasname'}) or die $dbh->errstr;
1076 sub sqlradius_nas_replace {
1077 my $dbh = sqlradius_connect(shift, shift, shift);
1079 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
1080 or die "nasnum ".$opt{'nasnum'}.' not found';
1081 my @values = map {$nas->$_}
1082 qw( nasname shortname type secret server community description );
1083 my $sth = $dbh->prepare('UPDATE nas SET
1084 nasname = ?, shortname = ?, type = ?, secret = ?,
1085 server = ?, community = ?, description = ?
1086 WHERE nasname = ?');
1087 $sth->execute(@values, $opt{'nasname'}) or die $dbh->errstr;
1090 =item export_attr_insert RADIUS_ATTR
1092 =item export_attr_delete RADIUS_ATTR
1094 =item export_attr_replace NEW_RADIUS_ATTR OLD_RADIUS_ATTR
1096 Update the group attribute tables (radgroupcheck and radgroupreply) on
1097 the RADIUS server. In delete and replace actions, the existing records
1098 are identified by the combination of group name and attribute name.
1100 In the special case where attributes are being replaced because a group
1101 name (L<FS::radius_group>->groupname) is changing, the pseudo-field
1102 'groupname' must be set in OLD_RADIUS_ATTR.
1106 # some false laziness with NAS export stuff...
1108 sub export_attr_insert { shift->export_attr_action('insert', @_); }
1110 sub export_attr_delete { shift->export_attr_action('delete', @_); }
1112 sub export_attr_replace { shift->export_attr_action('replace', @_); }
1114 sub export_attr_action {
1116 my ($action, $new, $old) = @_;
1119 if ( $action eq 'delete' ) {
1122 if ( $action eq 'delete' or $action eq 'replace' ) {
1123 # delete based on an exact match
1125 attrname => $old->attrname,
1126 attrtype => $old->attrtype,
1127 groupname => $old->groupname || $old->radius_group->groupname,
1129 value => $old->value,
1131 $err_or_queue = $self->sqlradius_queue('', 'attr_delete', %opt);
1132 return $err_or_queue unless ref $err_or_queue;
1134 # this probably doesn't matter, but just to be safe...
1135 my $jobnum = $err_or_queue->jobnum if $action eq 'replace';
1136 if ( $action eq 'replace' or $action eq 'insert' ) {
1138 attrname => $new->attrname,
1139 attrtype => $new->attrtype,
1140 groupname => $new->radius_group->groupname,
1142 value => $new->value,
1144 $err_or_queue = $self->sqlradius_queue('', 'attr_insert', %opt);
1145 $err_or_queue->depend_insert($jobnum) if $jobnum;
1146 return $err_or_queue unless ref $err_or_queue;
1151 sub sqlradius_attr_insert {
1152 my $dbh = sqlradius_connect(shift, shift, shift);
1156 # make sure $table is completely safe
1157 if ( $opt{'attrtype'} eq 'C' ) {
1158 $table = 'radgroupcheck';
1160 elsif ( $opt{'attrtype'} eq 'R' ) {
1161 $table = 'radgroupreply';
1164 die "unknown attribute type '$opt{attrtype}'";
1167 my @values = @opt{ qw(groupname attrname op value) };
1168 my $sth = $dbh->prepare(
1169 'INSERT INTO '.$table.' (groupname, attribute, op, value) VALUES (?,?,?,?)'
1171 $sth->execute(@values) or die $dbh->errstr;
1174 sub sqlradius_attr_delete {
1175 my $dbh = sqlradius_connect(shift, shift, shift);
1179 if ( $opt{'attrtype'} eq 'C' ) {
1180 $table = 'radgroupcheck';
1182 elsif ( $opt{'attrtype'} eq 'R' ) {
1183 $table = 'radgroupreply';
1186 die "unknown attribute type '".$opt{'attrtype'}."'";
1189 my @values = @opt{ qw(groupname attrname op value) };
1190 my $sth = $dbh->prepare(
1191 'DELETE FROM '.$table.
1192 ' WHERE groupname = ? AND attribute = ? AND op = ? AND value = ?'.
1195 $sth->execute(@values) or die $dbh->errstr;
1198 #sub sqlradius_attr_replace { no longer needed
1200 =item export_group_replace NEW OLD
1202 Replace the L<FS::radius_group> object OLD with NEW. This will change
1203 the group name and priority in all radusergroup records, and the group
1204 name in radgroupcheck and radgroupreply.
1208 sub export_group_replace {
1210 my ($new, $old) = @_;
1211 return '' if $new->groupname eq $old->groupname
1212 and $new->priority == $old->priority;
1214 my $err_or_queue = $self->sqlradius_queue(
1217 ($self->option('usergroup') || 'usergroup'),
1221 return $err_or_queue unless ref $err_or_queue;
1225 sub sqlradius_group_replace {
1226 my $dbh = sqlradius_connect(shift, shift, shift);
1227 my $usergroup = shift;
1228 $usergroup =~ /^(rad)?usergroup$/
1229 or die "bad usergroup table name: $usergroup";
1230 my ($new, $old) = (shift, shift);
1231 # apply renames to check/reply attribute tables
1232 if ( $new->{'groupname'} ne $old->{'groupname'} ) {
1233 foreach my $table (qw(radgroupcheck radgroupreply)) {
1234 my $sth = $dbh->prepare(
1235 'UPDATE '.$table.' SET groupname = ? WHERE groupname = ?'
1237 $sth->execute($new->{'groupname'}, $old->{'groupname'})
1238 or die $dbh->errstr;
1241 # apply renames and priority changes to usergroup table
1242 my $sth = $dbh->prepare(
1243 'UPDATE '.$usergroup.' SET groupname = ?, priority = ? WHERE groupname = ?'
1245 $sth->execute($new->{'groupname'}, $new->{'priority'}, $old->{'groupname'})
1246 or die $dbh->errstr;
1249 =item sqlradius_user_disconnect
1251 For a specified user, sends a disconnect request to all nas in the server database.
1253 Accepts L</sqlradius_connect> connection input and the following named parameters:
1255 I<disconnect_ssh> - user@host with access to radclient program (required)
1257 I<svc_acct_username> - the user to be disconnected (required)
1259 I<disconnect_port> - the port (on the nas) to send disconnect requests to (defaults to 1700)
1261 I<ignore_error> - do not die on error with the disconnect request
1263 Note this is NOT the opposite of sqlradius_connect.
1267 sub sqlradius_user_disconnect {
1268 my $dbh = sqlradius_connect(shift, shift, shift);
1271 my $sth = $dbh->prepare('select nasname, secret from nas') or die $dbh->errstr;
1272 $sth->execute() or die $dbh->errstr;
1273 my $nas = $sth->fetchall_arrayref({});
1276 die "No nas found in radius db" unless @$nas;
1277 # set up ssh connection
1278 my $ssh = Net::OpenSSH->new($opt{'disconnect_ssh'});
1279 die "Couldn't establish SSH connection: " . $ssh->error
1281 # send individual disconnect requests
1282 my $user = $opt{'svc_acct_username'}; #svc_acct username
1283 my $port = $opt{'disconnect_port'} || 1700; #or should we pull this from the db?
1285 foreach my $nas (@$nas) {
1286 my $nasname = $nas->{'nasname'};
1287 my $secret = $nas->{'secret'};
1288 my $command = qq(echo "User-Name=$user" | radclient -r 1 $nasname:$port disconnect '$secret');
1289 my ($output, $errput) = $ssh->capture2($command);
1290 $error .= "Error running $command: $errput " . $ssh->error . " "
1291 if $errput || $ssh->error;
1293 $error .= "Some clients may have successfully disconnected"
1294 if $error && (@$nas > 1);
1295 $error = "No clients found"
1297 die $error if $error && !$opt{'ignore_error'};
1302 # class method to fetch groups/attributes from the sqlradius install on upgrade
1305 sub _upgrade_exporttype {
1306 # do this only if the radius_attr table is empty
1307 local $FS::radius_attr::noexport_hack = 1;
1309 return if qsearch('radius_attr', {});
1311 foreach my $self ($class->all_sqlradius) {
1312 my $error = $self->import_attrs;
1313 die "exportnum ".$self->exportnum.":\n$error\n" if $error;
1320 my $dbh = DBI->connect( map $self->option($_),
1321 qw( datasrc username password ) );
1323 warn "Error connecting to RADIUS server: $DBI::errstr\n";
1327 my $usergroup = $self->option('usergroup') || 'usergroup';
1329 warn "Importing RADIUS groups and attributes from ".$self->option('datasrc').
1332 # map out existing groups and attrs
1335 foreach my $radius_group ( qsearch('radius_group', {}) ) {
1336 $attrs_of{$radius_group->groupname} = +{
1337 map { $_->attrname => $_ } $radius_group->radius_attr
1339 $groupnum_of{$radius_group->groupname} = $radius_group->groupnum;
1342 # get groupnames from radgroupcheck and radgroupreply
1344 SELECT groupname, attribute, op, value, \'C\' FROM radgroupcheck
1346 SELECT groupname, attribute, op, value, \'R\' FROM radgroupreply';
1347 my @fixes; # things that need to be changed on the radius db
1348 foreach my $row ( @{ $dbh->selectall_arrayref($sql) } ) {
1349 my ($groupname, $attrname, $op, $value, $attrtype) = @$row;
1350 warn "$groupname.$attrname\n";
1351 if ( !exists($groupnum_of{$groupname}) ) {
1352 my $radius_group = new FS::radius_group {
1353 'groupname' => $groupname,
1356 $error = $radius_group->insert;
1358 warn "error inserting group $groupname: $error";
1359 next;#don't continue trying to insert the attribute
1361 $attrs_of{$groupname} = {};
1362 $groupnum_of{$groupname} = $radius_group->groupnum;
1365 my $a = $attrs_of{$groupname};
1366 my $old = $a->{$attrname};
1369 if ( $attrtype eq 'R' ) {
1370 # Freeradius tolerates illegal operators in reply attributes. We don't.
1371 if ( !grep ($_ eq $op, FS::radius_attr->ops('R')) ) {
1372 warn "$groupname.$attrname: changing $op to +=\n";
1373 # Make a note to change it in the db
1375 'UPDATE radgroupreply SET op = \'+=\' WHERE groupname = ? AND attribute = ? AND op = ? AND VALUE = ?',
1376 $groupname, $attrname, $op, $value
1378 # and import it correctly.
1383 if ( defined $old ) {
1385 $new = new FS::radius_attr {
1390 $error = $new->replace($old);
1392 warn "error modifying attr $attrname: $error";
1397 $new = new FS::radius_attr {
1398 'groupnum' => $groupnum_of{$groupname},
1399 'attrname' => $attrname,
1400 'attrtype' => $attrtype,
1404 $error = $new->insert;
1406 warn "error inserting attr $attrname: $error" if $error;
1410 $attrs_of{$groupname}->{$attrname} = $new;
1414 my ($sql, @args) = @$_;
1415 my $sth = $dbh->prepare($sql);
1416 $sth->execute(@args) or warn $sth->errstr;
1429 #don't just look for ->can('usage_sessions'), we're sqlradius-specific
1430 # (radiator is supposed to be setup with a radacct table)
1431 #i suppose it would be more slick to look for things that inherit from us..
1433 my @part_export = ();
1434 push @part_export, qsearch('part_export', { 'exporttype' => $_ } )
1435 foreach qw( sqlradius sqlradius_withdomain radiator phone_sqlradius
1436 broadband_sqlradius );
1440 sub all_sqlradius_withaccounting {
1442 grep { ! $_->option('ignore_accounting') } $class->all_sqlradius;