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 'skip_provisioning' => {
31 label => 'Skip provisioning records to this database'
33 'ignore_accounting' => {
35 label => 'Ignore accounting records from this database'
37 'process_single_realm' => {
39 label => 'Only process one realm of accounting records',
41 'realm' => { label => 'The realm of of accounting records to be processed' },
42 'ignore_long_sessions' => {
44 label => 'Ignore sessions which span billing periods',
48 label => 'Hide IP address information on session reports',
52 label => 'Hide download/upload information on session reports',
54 'show_called_station' => {
56 label => 'Show the Called-Station-ID on session reports', #as a phone number
58 'overlimit_groups' => {
59 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)',
65 option_values => sub {
67 map { $_->groupnum, $_->long_description }
68 qsearch('radius_group', {}),
73 'groups_susp_reason' => { label =>
74 'Radius group mapping to reason (via template user) (svcnum|username|username@domain reasonnum|reason)',
79 label => 'Export RADIUS group attributes to this database',
82 label => 'To send a disconnection request to each RADIUS client when modifying, suspending or deleting an account, enter a ssh connection string (username@host) with access to the radclient program',
84 'disconnect_port' => {
85 label => 'Port to send disconnection requests to, default 1700',
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 return '' if $self->option('skip_provisioning');
163 foreach my $table (qw(reply check)) {
164 my $method = "radius_$table";
165 my %attrib = $self->$method($svc_x);
166 next unless keys %attrib;
167 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'insert',
168 $table, $self->export_username($svc_x), %attrib );
169 return $err_or_queue unless ref($err_or_queue);
171 my @groups = $svc_x->radius_groups('hashref');
173 cluck localtime(). ": queuing usergroup_insert for ". $svc_x->svcnum.
174 " (". $self->export_username($svc_x). " with ". join(", ", @groups)
176 my $usergroup = $self->option('usergroup') || 'usergroup';
177 my $err_or_queue = $self->sqlradius_queue(
178 $svc_x->svcnum, 'usergroup_insert',
179 $self->export_username($svc_x), $usergroup, @groups );
180 return $err_or_queue unless ref($err_or_queue);
185 sub _export_replace {
186 my( $self, $new, $old ) = (shift, shift, shift);
188 return '' if $self->option('skip_provisioning');
190 local $SIG{HUP} = 'IGNORE';
191 local $SIG{INT} = 'IGNORE';
192 local $SIG{QUIT} = 'IGNORE';
193 local $SIG{TERM} = 'IGNORE';
194 local $SIG{TSTP} = 'IGNORE';
195 local $SIG{PIPE} = 'IGNORE';
197 my $oldAutoCommit = $FS::UID::AutoCommit;
198 local $FS::UID::AutoCommit = 0;
202 if ( $self->export_username($old) ne $self->export_username($new) ) {
203 my $usergroup = $self->option('usergroup') || 'usergroup';
204 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'rename',
205 $self->export_username($new), $self->export_username($old), $usergroup );
206 unless ( ref($err_or_queue) ) {
207 $dbh->rollback if $oldAutoCommit;
208 return $err_or_queue;
210 $jobnum = $err_or_queue->jobnum;
213 foreach my $table (qw(reply check)) {
214 my $method = "radius_$table";
215 my %new = $self->$method($new);
216 my %old = $self->$method($old);
217 if ( grep { !exists $old{$_} #new attributes
218 || $new{$_} ne $old{$_} #changed
221 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
222 $table, $self->export_username($new), %new );
223 unless ( ref($err_or_queue) ) {
224 $dbh->rollback if $oldAutoCommit;
225 return $err_or_queue;
228 my $error = $err_or_queue->depend_insert( $jobnum );
230 $dbh->rollback if $oldAutoCommit;
234 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
237 my @del = grep { !exists $new{$_} } keys %old;
239 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'attrib_delete',
240 $table, $self->export_username($new), @del );
241 unless ( ref($err_or_queue) ) {
242 $dbh->rollback if $oldAutoCommit;
243 return $err_or_queue;
246 my $error = $err_or_queue->depend_insert( $jobnum );
248 $dbh->rollback if $oldAutoCommit;
252 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
257 my (@oldgroups) = $old->radius_groups('hashref');
258 my (@newgroups) = $new->radius_groups('hashref');
259 ($error,$jobnum) = $self->sqlreplace_usergroups( $new->svcnum,
260 $self->export_username($new),
261 $jobnum ? $jobnum : '',
266 $dbh->rollback if $oldAutoCommit;
270 # radius database is used for authorization, so to avoid users reauthorizing
271 # before the database changes, disconnect users after changing database
272 if ($self->option('disconnect_ssh')) {
273 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'user_disconnect',
274 'disconnect_ssh' => $self->option('disconnect_ssh'),
275 'svc_acct_username' => $old->username,
276 'disconnect_port' => $self->option('disconnect_port'),
278 unless ( ref($err_or_queue) ) {
279 $dbh->rollback if $oldAutoCommit;
280 return $err_or_queue;
283 my $error = $err_or_queue->depend_insert( $jobnum );
285 $dbh->rollback if $oldAutoCommit;
291 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
296 #false laziness w/broadband_sqlradius.pm
297 sub _export_suspend {
298 my( $self, $svc_acct ) = (shift, shift);
300 return '' if $self->option('skip_provisioning');
302 my $new = $svc_acct->clone_suspended;
304 local $SIG{HUP} = 'IGNORE';
305 local $SIG{INT} = 'IGNORE';
306 local $SIG{QUIT} = 'IGNORE';
307 local $SIG{TERM} = 'IGNORE';
308 local $SIG{TSTP} = 'IGNORE';
309 local $SIG{PIPE} = 'IGNORE';
311 my $oldAutoCommit = $FS::UID::AutoCommit;
312 local $FS::UID::AutoCommit = 0;
317 my @newgroups = $self->suspended_usergroups($svc_acct);
319 unless (@newgroups) { #don't change password if assigning to a suspended group
321 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
322 'check', $self->export_username($new), $new->radius_check );
323 unless ( ref($err_or_queue) ) {
324 $dbh->rollback if $oldAutoCommit;
325 return $err_or_queue;
327 $jobnum = $err_or_queue->jobnum;
332 $self->sqlreplace_usergroups(
334 $self->export_username($new),
336 [ $svc_acct->radius_groups('hashref') ],
340 $dbh->rollback if $oldAutoCommit;
344 # radius database is used for authorization, so to avoid users reauthorizing
345 # before the database changes, disconnect users after changing database
346 if ($self->option('disconnect_ssh')) {
347 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'user_disconnect',
348 'disconnect_ssh' => $self->option('disconnect_ssh'),
349 'svc_acct_username' => $svc_acct->username,
350 'disconnect_port' => $self->option('disconnect_port'),
352 unless ( ref($err_or_queue) ) {
353 $dbh->rollback if $oldAutoCommit;
354 return $err_or_queue;
357 my $error = $err_or_queue->depend_insert( $jobnum );
359 $dbh->rollback if $oldAutoCommit;
365 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
370 sub _export_unsuspend {
371 my( $self, $svc_x ) = (shift, shift);
373 return '' if $self->option('skip_provisioning');
375 local $SIG{HUP} = 'IGNORE';
376 local $SIG{INT} = 'IGNORE';
377 local $SIG{QUIT} = 'IGNORE';
378 local $SIG{TERM} = 'IGNORE';
379 local $SIG{TSTP} = 'IGNORE';
380 local $SIG{PIPE} = 'IGNORE';
382 my $oldAutoCommit = $FS::UID::AutoCommit;
383 local $FS::UID::AutoCommit = 0;
386 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'insert',
387 'check', $self->export_username($svc_x), $self->radius_check($svc_x) );
388 unless ( ref($err_or_queue) ) {
389 $dbh->rollback if $oldAutoCommit;
390 return $err_or_queue;
394 my (@oldgroups) = $self->suspended_usergroups($svc_x);
395 $error = $self->sqlreplace_usergroups(
397 $self->export_username($svc_x),
400 [ $svc_x->radius_groups('hashref') ],
403 $dbh->rollback if $oldAutoCommit;
406 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
412 my( $self, $svc_x ) = (shift, shift);
414 return '' if $self->option('skip_provisioning');
418 my $usergroup = $self->option('usergroup') || 'usergroup';
419 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'delete',
420 $self->export_username($svc_x), $usergroup );
421 $jobnum = $err_or_queue->jobnum;
423 # radius database is used for authorization, so to avoid users reauthorizing
424 # before the database changes, disconnect users after changing database
425 if ($self->option('disconnect_ssh')) {
426 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'user_disconnect',
427 'disconnect_ssh' => $self->option('disconnect_ssh'),
428 'svc_acct_username' => $svc_x->username,
429 'disconnect_port' => $self->option('disconnect_port'),
431 return $err_or_queue unless ref($err_or_queue);
433 my $error = $err_or_queue->depend_insert( $jobnum );
434 return $error if $error;
438 ref($err_or_queue) ? '' : $err_or_queue;
441 sub sqlradius_queue {
442 my( $self, $svcnum, $method ) = (shift, shift, shift);
444 my $queue = new FS::queue {
446 'job' => "FS::part_export::sqlradius::sqlradius_$method",
449 $self->option('datasrc'),
450 $self->option('username'),
451 $self->option('password'),
456 sub suspended_usergroups {
457 my ($self, $svc_x) = (shift, shift);
459 return () unless $svc_x;
461 my $svc_table = $svc_x->table;
463 #false laziness with FS::part_export::shellcommands
464 #subclass part_export?
466 my $r = $svc_x->cust_svc->cust_pkg->last_reason('susp');
467 my %reasonmap = $self->_groups_susp_reason_map;
470 $userspec = $reasonmap{$r->reasonnum}
471 if exists($reasonmap{$r->reasonnum});
472 $userspec = $reasonmap{$r->reason}
473 if (!$userspec && exists($reasonmap{$r->reason}));
476 if ( $userspec =~ /^\d+$/ ){
477 $suspend_svc = qsearchs( $svc_table, { 'svcnum' => $userspec } );
478 } elsif ( $userspec =~ /^\S+\@\S+$/ && $svc_table eq 'svc_acct' ){
479 my ($username,$domain) = split(/\@/, $userspec);
480 for my $user (qsearch( 'svc_acct', { 'username' => $username } )){
481 $suspend_svc = $user if $userspec eq $user->email;
483 }elsif ( $userspec && $svc_table eq 'svc_acct' ){
484 $suspend_svc = qsearchs( 'svc_acct', { 'username' => $userspec } );
487 return $suspend_svc->radius_groups('hashref') if $suspend_svc;
491 sub sqlradius_insert { #subroutine, not method
492 my $dbh = sqlradius_connect(shift, shift, shift);
493 my( $table, $username, %attributes ) = @_;
495 foreach my $attribute ( keys %attributes ) {
497 my $s_sth = $dbh->prepare(
498 "SELECT COUNT(*) FROM rad$table WHERE UserName = ? AND Attribute = ?"
499 ) or die $dbh->errstr;
500 $s_sth->execute( $username, $attribute ) or die $s_sth->errstr;
502 if ( $s_sth->fetchrow_arrayref->[0] ) {
504 my $u_sth = $dbh->prepare(
505 "UPDATE rad$table SET Value = ? WHERE UserName = ? AND Attribute = ?"
506 ) or die $dbh->errstr;
507 $u_sth->execute($attributes{$attribute}, $username, $attribute)
508 or die $u_sth->errstr;
512 my $i_sth = $dbh->prepare(
513 "INSERT INTO rad$table ( UserName, Attribute, op, Value ) ".
514 "VALUES ( ?, ?, ?, ? )"
515 ) or die $dbh->errstr;
519 ( $attribute eq 'Password' ? '==' : ':=' ),
520 $attributes{$attribute},
521 ) or die $i_sth->errstr;
529 sub sqlradius_usergroup_insert { #subroutine, not method
530 my $dbh = sqlradius_connect(shift, shift, shift);
531 my $username = shift;
532 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
535 my $s_sth = $dbh->prepare(
536 "SELECT COUNT(*) FROM $usergroup WHERE UserName = ? AND GroupName = ?"
537 ) or die $dbh->errstr;
539 my $sth = $dbh->prepare(
540 "INSERT INTO $usergroup ( UserName, GroupName, Priority ) VALUES ( ?, ?, ? )"
541 ) or die $dbh->errstr;
543 foreach ( @groups ) {
544 my $group = $_->{'groupname'};
545 my $priority = $_->{'priority'};
546 $s_sth->execute( $username, $group ) or die $s_sth->errstr;
547 if ($s_sth->fetchrow_arrayref->[0]) {
548 warn localtime() . ": sqlradius_usergroup_insert attempted to reinsert " .
549 "$group for $username\n"
553 $sth->execute( $username, $group, $priority )
554 or die "can't insert into groupname table: ". $sth->errstr;
556 if ( $s_sth->{Active} ) {
557 warn "sqlradius s_sth still active; calling ->finish()";
560 if ( $sth->{Active} ) {
561 warn "sqlradius sth still active; calling ->finish()";
567 sub sqlradius_usergroup_delete { #subroutine, not method
568 my $dbh = sqlradius_connect(shift, shift, shift);
569 my $username = shift;
570 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
573 my $sth = $dbh->prepare(
574 "DELETE FROM $usergroup WHERE UserName = ? AND GroupName = ?"
575 ) or die $dbh->errstr;
576 foreach ( @groups ) {
577 my $group = $_->{'groupname'};
578 $sth->execute( $username, $group )
579 or die "can't delete from groupname table: ". $sth->errstr;
584 sub sqlradius_rename { #subroutine, not method
585 my $dbh = sqlradius_connect(shift, shift, shift);
586 my($new_username, $old_username) = (shift, shift);
587 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
588 foreach my $table (qw(radreply radcheck), $usergroup ) {
589 my $sth = $dbh->prepare("UPDATE $table SET Username = ? WHERE UserName = ?")
591 $sth->execute($new_username, $old_username)
592 or die "can't update $table: ". $sth->errstr;
597 sub sqlradius_attrib_delete { #subroutine, not method
598 my $dbh = sqlradius_connect(shift, shift, shift);
599 my( $table, $username, @attrib ) = @_;
601 foreach my $attribute ( @attrib ) {
602 my $sth = $dbh->prepare(
603 "DELETE FROM rad$table WHERE UserName = ? AND Attribute = ?" )
605 $sth->execute($username,$attribute)
606 or die "can't delete from rad$table table: ". $sth->errstr;
611 sub sqlradius_delete { #subroutine, not method
612 my $dbh = sqlradius_connect(shift, shift, shift);
613 my $username = shift;
614 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
616 foreach my $table (qw( radcheck radreply), $usergroup ) {
617 my $sth = $dbh->prepare( "DELETE FROM $table WHERE UserName = ?" );
618 $sth->execute($username)
619 or die "can't delete from $table table: ". $sth->errstr;
624 sub sqlradius_connect {
625 #my($datasrc, $username, $password) = @_;
626 #DBI->connect($datasrc, $username, $password) or die $DBI::errstr;
627 DBI->connect(@_) or die $DBI::errstr;
630 # on success, returns '' in scalar context, ('',$jobnum) in list context
631 # on error, always just returns error
632 sub sqlreplace_usergroups {
633 my ($self, $svcnum, $username, $jobnum, $old, $new) = @_;
635 # (sorta) false laziness with FS::svc_acct::replace
636 my @oldgroups = @$old;
637 my @newgroups = @$new;
639 foreach my $oldgroup ( @oldgroups ) {
640 if ( grep { $oldgroup eq $_ } @newgroups ) {
641 @newgroups = grep { $oldgroup ne $_ } @newgroups;
644 push @delgroups, $oldgroup;
647 my $usergroup = $self->option('usergroup') || 'usergroup';
650 my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_delete',
651 $username, $usergroup, @delgroups );
653 unless ref($err_or_queue);
655 my $error = $err_or_queue->depend_insert( $jobnum );
656 return $error if $error;
658 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
662 cluck localtime(). ": queuing usergroup_insert for $svcnum ($username) ".
663 "with ". join(", ", @newgroups)
665 my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_insert',
666 $username, $usergroup, @newgroups );
668 unless ref($err_or_queue);
670 my $error = $err_or_queue->depend_insert( $jobnum );
671 return $error if $error;
673 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
675 wantarray ? ('',$jobnum) : '';
681 =item usage_sessions HASHREF
683 =item usage_sessions TIMESTAMP_START TIMESTAMP_END [ SVC_ACCT [ IP [ PREFIX [ SQL_SELECT ] ] ] ]
685 New-style: pass a hashref with the following keys:
689 =item stoptime_start - Lower bound for AcctStopTime, as a UNIX timestamp
691 =item stoptime_end - Upper bound for AcctStopTime, as a UNIX timestamp
693 =item session_status - 'closed' to only show records with AcctStopTime,
694 'open' to only show records I<without> AcctStopTime, empty to show both.
696 =item starttime_start - Lower bound for AcctStartTime, as a UNIX timestamp
698 =item starttime_end - Upper bound for AcctStartTime, as a UNIX timestamp
710 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
711 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
714 SVC_ACCT, if specified, limits the results to the specified account.
716 IP, if specified, limits the results to the specified IP address.
718 PREFIX, if specified, limits the results to records with a matching
721 #SQL_SELECT defaults to * if unspecified. It can be useful to set it to
722 #SUM(acctsessiontime) or SUM(AcctInputOctets), etc.
724 Returns an arrayref of hashrefs with the following fields:
730 =item framedipaddress
736 =item acctsessiontime
738 =item acctinputoctets
740 =item acctoutputoctets
742 =item callingstationid
744 =item calledstationid
750 #some false laziness w/cust_svc::seconds_since_sqlradacct
756 my($start, $end, $svc_acct, $ip, $prefix) = ( '', '', '', '', '');
760 $start = $opt->{stoptime_start};
761 $end = $opt->{stoptime_end};
762 $svc_acct = $opt->{svc} || $opt->{svc_acct};
764 $prefix = $opt->{prefix};
765 $summarize = $opt->{summarize};
767 ( $start, $end ) = splice(@_, 0, 2);
768 $svc_acct = @_ ? shift : '';
769 $ip = @_ ? shift : '';
770 $prefix = @_ ? shift : '';
771 #my $select = @_ ? shift : '*';
776 return [] if $self->option('ignore_accounting');
778 my $dbh = sqlradius_connect( map $self->option($_),
779 qw( datasrc username password ) );
781 #select a unix time conversion function based on database type
782 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
783 my $closing = str2time_sql_closing( $dbh->{Driver}->{Name} );
786 qw( username realm framedipaddress
787 acctsessiontime acctinputoctets acctoutputoctets
788 callingstationid calledstationid
790 "$str2time acctstarttime $closing as acctstarttime",
791 "$str2time acctstoptime $closing as acctstoptime",
794 @fields = ( 'username', 'sum(acctsessiontime) as acctsessiontime', 'sum(acctinputoctets) as acctinputoctets',
795 'sum(acctoutputoctets) as acctoutputoctets',
802 my $username = $self->export_username($svc_acct);
803 if ( $username =~ /^([^@]+)\@([^@]+)$/ ) {
804 push @where, '( UserName = ? OR ( UserName = ? AND Realm = ? ) )';
805 push @param, $username, $1, $2;
807 push @where, 'UserName = ?';
808 push @param, $username;
812 if ($self->option('process_single_realm')) {
813 push @where, 'Realm = ?';
814 push @param, $self->option('realm');
818 push @where, ' FramedIPAddress = ?';
822 if ( length($prefix) ) {
823 #assume sip: for now, else things get ugly trying to match /^\w+:$prefix/
824 push @where, " CalledStationID LIKE 'sip:$prefix\%'";
827 my $acctstoptime = '';
828 if ( $opt->{session_status} ne 'open' ) {
830 $acctstoptime .= "$str2time AcctStopTime $closing >= ?";
832 $acctstoptime .= ' AND ' if $end;
835 $acctstoptime .= "$str2time AcctStopTime $closing <= ?";
839 if ( $opt->{session_status} ne 'closed' ) {
840 if ( $acctstoptime ) {
841 $acctstoptime = "( ( $acctstoptime ) OR AcctStopTime IS NULL )";
843 $acctstoptime = 'AcctStopTime IS NULL';
846 push @where, $acctstoptime;
848 if ( $opt->{starttime_start} ) {
849 push @where, "$str2time AcctStartTime $closing >= ?";
850 push @param, $opt->{starttime_start};
852 if ( $opt->{starttime_end} ) {
853 push @where, "$str2time AcctStartTime $closing <= ?";
854 push @param, $opt->{starttime_end};
857 my $where = join(' AND ', @where);
858 $where = "WHERE $where" if $where;
861 $groupby = 'GROUP BY username' if $summarize;
863 my $orderby = 'ORDER BY AcctStartTime DESC';
864 $orderby = '' if $summarize;
866 my $sql = 'SELECT '. join(', ', @fields).
867 " FROM radacct $where $groupby $orderby";
870 warn join(',', @param);
872 my $sth = $dbh->prepare($sql) or die $dbh->errstr;
873 $sth->execute(@param) or die $sth->errstr;
875 [ map { { %$_ } } @{ $sth->fetchall_arrayref({}) } ];
886 my $conf = new FS::Conf;
889 my $dbh = sqlradius_connect( map $self->option($_),
890 qw( datasrc username password ) );
892 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
893 my $closing = str2time_sql_closing( $dbh->{Driver}->{Name} );
895 my @fields = qw( radacctid username realm acctsessiontime );
900 my $sth = $dbh->prepare("
901 SELECT RadAcctId, UserName, Realm, AcctSessionTime,
902 $str2time AcctStartTime $closing, $str2time AcctStopTime $closing,
903 AcctInputOctets, AcctOutputOctets
905 WHERE FreesideStatus IS NULL
906 AND AcctStopTime IS NOT NULL
907 ") or die $dbh->errstr;
908 $sth->execute() or die $sth->errstr;
910 while ( my $row = $sth->fetchrow_arrayref ) {
911 my($RadAcctId, $UserName, $Realm, $AcctSessionTime, $AcctStartTime,
912 $AcctStopTime, $AcctInputOctets, $AcctOutputOctets) = @$row;
913 warn "processing record: ".
914 "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s"
917 my $fs_username = $UserName;
919 $fs_username = lc($fs_username) unless $conf->exists('username-uppercase');
921 #my %search = ( 'username' => $fs_username );
924 my $errinfo = "for RADIUS detail RadAcctID $RadAcctId ".
925 "(UserName $UserName, Realm $Realm)";
928 if ( ref($self) =~ /withdomain/ ) { #well, should be a callback to that
933 } elsif ( $fs_username =~ /\@/ ) {
934 ($fs_username, $domain) = split('@', $fs_username);
936 warn 'WARNING: nothing Realm column and no @realm in UserName column '.
937 "$errinfo -- skipping\n" if $DEBUG;
938 $status = 'skipped (no realm)';
941 $extra_sql = " AND '$domain' = ( SELECT domain FROM svc_domain
942 WHERE svc_domain.svcnum = svc_acct.domsvc ) ";
945 my $oldAutoCommit = $FS::UID::AutoCommit; # can't undo side effects, but at
946 local $FS::UID::AutoCommit = 0; # least we can avoid over counting
952 if ( $self->option('process_single_realm')
953 && $self->option('realm') ne $Realm )
955 warn "WARNING: wrong realm $errinfo - skipping\n" if $DEBUG;
958 grep { qsearch( 'export_svc', { 'exportnum' => $self->exportnum,
959 'svcpart' => $_->cust_svc->svcpart,
964 { 'username' => $fs_username },
970 warn "WARNING: no svc_acct record found $errinfo - skipping\n";
971 } elsif ( scalar(@svc_acct) > 1 ) {
972 warn "WARNING: multiple svc_acct records found $errinfo - skipping\n";
975 my $svc_acct = $svc_acct[0];
976 warn "found svc_acct ". $svc_acct->svcnum. " $errinfo\n" if $DEBUG;
978 $svc_acct->last_login($AcctStartTime);
979 $svc_acct->last_logout($AcctStopTime);
981 my $session_time = $AcctStopTime;
982 $session_time = $AcctStartTime
983 if $self->option('ignore_long_sessions');
985 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
986 if ( $cust_pkg && $session_time < ( $cust_pkg->last_bill
987 || $cust_pkg->setup ) ) {
988 $status = 'skipped (too old)';
991 push @st, _try_decrement($svc_acct,'seconds', $AcctSessionTime);
992 push @st, _try_decrement($svc_acct,'upbytes', $AcctInputOctets);
993 push @st, _try_decrement($svc_acct,'downbytes', $AcctOutputOctets);
994 push @st, _try_decrement($svc_acct,'totalbytes', $AcctInputOctets
995 + $AcctOutputOctets);
996 $status=join(' ', @st);
1003 warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG;
1004 my $psth = $dbh->prepare("UPDATE radacct
1005 SET FreesideStatus = ?
1006 WHERE RadAcctId = ?"
1007 ) or die $dbh->errstr;
1008 $psth->execute($status, $RadAcctId) or die $psth->errstr;
1010 $fdbh->commit or die $fdbh->errstr if $oldAutoCommit;
1016 sub _try_decrement {
1017 my ($svc_acct, $column, $amount) = @_;
1018 if ( $svc_acct->$column !~ /^$/ ) {
1019 warn " svc_acct.$column found (". $svc_acct->$column.
1020 ") - decrementing\n"
1022 my $method = 'decrement_' . $column;
1023 my $error = $svc_acct->$method($amount);
1024 die $error if $error;
1027 warn " no existing $column value for svc_acct - skipping\n" if $DEBUG;
1032 =item export_nas_insert NAS
1034 =item export_nas_delete NAS
1036 =item export_nas_replace NEW_NAS OLD_NAS
1038 Update the NAS table (allowed RADIUS clients) on the attached RADIUS
1039 server. Currently requires the table to be named 'nas' and to follow
1040 the stock schema (/etc/freeradius/nas.sql).
1044 sub export_nas_insert { shift->export_nas_action('insert', @_); }
1045 sub export_nas_delete { shift->export_nas_action('delete', @_); }
1046 sub export_nas_replace { shift->export_nas_action('replace', @_); }
1048 sub export_nas_action {
1050 my ($action, $new, $old) = @_;
1051 # find the NAS in the target table by its name
1052 my $nasname = ($action eq 'replace') ? $old->nasname : $new->nasname;
1053 my $nasnum = $new->nasnum;
1055 my $err_or_queue = $self->sqlradius_queue('', "nas_$action",
1056 nasname => $nasname,
1059 return $err_or_queue unless ref $err_or_queue;
1063 sub sqlradius_nas_insert {
1064 my $dbh = sqlradius_connect(shift, shift, shift);
1066 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
1067 or die "nasnum ".$opt{'nasnum'}.' not found';
1068 # insert actual NULLs where FS::Record has translated to empty strings
1069 my @values = map { length($nas->$_) ? $nas->$_ : undef }
1070 qw( nasname shortname type secret server community description );
1071 my $sth = $dbh->prepare('INSERT INTO nas
1072 (nasname, shortname, type, secret, server, community, description)
1073 VALUES (?, ?, ?, ?, ?, ?, ?)');
1074 $sth->execute(@values) or die $dbh->errstr;
1077 sub sqlradius_nas_delete {
1078 my $dbh = sqlradius_connect(shift, shift, shift);
1080 my $sth = $dbh->prepare('DELETE FROM nas WHERE nasname = ?');
1081 $sth->execute($opt{'nasname'}) or die $dbh->errstr;
1084 sub sqlradius_nas_replace {
1085 my $dbh = sqlradius_connect(shift, shift, shift);
1087 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
1088 or die "nasnum ".$opt{'nasnum'}.' not found';
1089 my @values = map {$nas->$_}
1090 qw( nasname shortname type secret server community description );
1091 my $sth = $dbh->prepare('UPDATE nas SET
1092 nasname = ?, shortname = ?, type = ?, secret = ?,
1093 server = ?, community = ?, description = ?
1094 WHERE nasname = ?');
1095 $sth->execute(@values, $opt{'nasname'}) or die $dbh->errstr;
1098 =item export_attr_insert RADIUS_ATTR
1100 =item export_attr_delete RADIUS_ATTR
1102 =item export_attr_replace NEW_RADIUS_ATTR OLD_RADIUS_ATTR
1104 Update the group attribute tables (radgroupcheck and radgroupreply) on
1105 the RADIUS server. In delete and replace actions, the existing records
1106 are identified by the combination of group name and attribute name.
1108 In the special case where attributes are being replaced because a group
1109 name (L<FS::radius_group>->groupname) is changing, the pseudo-field
1110 'groupname' must be set in OLD_RADIUS_ATTR.
1114 # some false laziness with NAS export stuff...
1116 sub export_attr_insert { shift->export_attr_action('insert', @_); }
1118 sub export_attr_delete { shift->export_attr_action('delete', @_); }
1120 sub export_attr_replace { shift->export_attr_action('replace', @_); }
1122 sub export_attr_action {
1124 my ($action, $new, $old) = @_;
1127 if ( $action eq 'delete' ) {
1130 if ( $action eq 'delete' or $action eq 'replace' ) {
1131 # delete based on an exact match
1133 attrname => $old->attrname,
1134 attrtype => $old->attrtype,
1135 groupname => $old->groupname || $old->radius_group->groupname,
1137 value => $old->value,
1139 $err_or_queue = $self->sqlradius_queue('', 'attr_delete', %opt);
1140 return $err_or_queue unless ref $err_or_queue;
1142 # this probably doesn't matter, but just to be safe...
1143 my $jobnum = $err_or_queue->jobnum if $action eq 'replace';
1144 if ( $action eq 'replace' or $action eq 'insert' ) {
1146 attrname => $new->attrname,
1147 attrtype => $new->attrtype,
1148 groupname => $new->radius_group->groupname,
1150 value => $new->value,
1152 $err_or_queue = $self->sqlradius_queue('', 'attr_insert', %opt);
1153 $err_or_queue->depend_insert($jobnum) if $jobnum;
1154 return $err_or_queue unless ref $err_or_queue;
1159 sub sqlradius_attr_insert {
1160 my $dbh = sqlradius_connect(shift, shift, shift);
1164 # make sure $table is completely safe
1165 if ( $opt{'attrtype'} eq 'C' ) {
1166 $table = 'radgroupcheck';
1168 elsif ( $opt{'attrtype'} eq 'R' ) {
1169 $table = 'radgroupreply';
1172 die "unknown attribute type '$opt{attrtype}'";
1175 my @values = @opt{ qw(groupname attrname op value) };
1176 my $sth = $dbh->prepare(
1177 'INSERT INTO '.$table.' (groupname, attribute, op, value) VALUES (?,?,?,?)'
1179 $sth->execute(@values) or die $dbh->errstr;
1182 sub sqlradius_attr_delete {
1183 my $dbh = sqlradius_connect(shift, shift, shift);
1187 if ( $opt{'attrtype'} eq 'C' ) {
1188 $table = 'radgroupcheck';
1190 elsif ( $opt{'attrtype'} eq 'R' ) {
1191 $table = 'radgroupreply';
1194 die "unknown attribute type '".$opt{'attrtype'}."'";
1197 my @values = @opt{ qw(groupname attrname op value) };
1198 my $sth = $dbh->prepare(
1199 'DELETE FROM '.$table.
1200 ' WHERE groupname = ? AND attribute = ? AND op = ? AND value = ?'.
1203 $sth->execute(@values) or die $dbh->errstr;
1206 #sub sqlradius_attr_replace { no longer needed
1208 =item export_group_replace NEW OLD
1210 Replace the L<FS::radius_group> object OLD with NEW. This will change
1211 the group name and priority in all radusergroup records, and the group
1212 name in radgroupcheck and radgroupreply.
1216 sub export_group_replace {
1218 my ($new, $old) = @_;
1219 return '' if $new->groupname eq $old->groupname
1220 and $new->priority == $old->priority;
1222 my $err_or_queue = $self->sqlradius_queue(
1225 ($self->option('usergroup') || 'usergroup'),
1229 return $err_or_queue unless ref $err_or_queue;
1233 sub sqlradius_group_replace {
1234 my $dbh = sqlradius_connect(shift, shift, shift);
1235 my $usergroup = shift;
1236 $usergroup =~ /^(rad)?usergroup$/
1237 or die "bad usergroup table name: $usergroup";
1238 my ($new, $old) = (shift, shift);
1239 # apply renames to check/reply attribute tables
1240 if ( $new->{'groupname'} ne $old->{'groupname'} ) {
1241 foreach my $table (qw(radgroupcheck radgroupreply)) {
1242 my $sth = $dbh->prepare(
1243 'UPDATE '.$table.' SET groupname = ? WHERE groupname = ?'
1245 $sth->execute($new->{'groupname'}, $old->{'groupname'})
1246 or die $dbh->errstr;
1249 # apply renames and priority changes to usergroup table
1250 my $sth = $dbh->prepare(
1251 'UPDATE '.$usergroup.' SET groupname = ?, priority = ? WHERE groupname = ?'
1253 $sth->execute($new->{'groupname'}, $new->{'priority'}, $old->{'groupname'})
1254 or die $dbh->errstr;
1257 =item sqlradius_user_disconnect
1259 For a specified user, sends a disconnect request to all nas in the server database.
1261 Accepts L</sqlradius_connect> connection input and the following named parameters:
1263 I<disconnect_ssh> - user@host with access to radclient program (required)
1265 I<svc_acct_username> - the user to be disconnected (required)
1267 I<disconnect_port> - the port (on the nas) to send disconnect requests to (defaults to 1700)
1269 Note this is NOT the opposite of sqlradius_connect.
1273 sub sqlradius_user_disconnect {
1274 my $dbh = sqlradius_connect(shift, shift, shift);
1277 my $sth = $dbh->prepare('select nasname, secret from nas') or die $dbh->errstr;
1278 $sth->execute() or die $dbh->errstr;
1279 my $nas = $sth->fetchall_arrayref({});
1282 die "No nas found in radius db" unless @$nas;
1283 # set up ssh connection
1284 my $ssh = Net::OpenSSH->new($opt{'disconnect_ssh'});
1285 die "Couldn't establish SSH connection: " . $ssh->error
1287 # send individual disconnect requests
1288 my $user = $opt{'svc_acct_username'}; #svc_acct username
1289 my $port = $opt{'disconnect_port'} || 1700; #or should we pull this from the db?
1291 foreach my $nas (@$nas) {
1292 my $nasname = $nas->{'nasname'};
1293 my $secret = $nas->{'secret'};
1294 my $command = qq(echo "User-Name=$user" | radclient -r 1 $nasname:$port disconnect '$secret');
1295 my ($output, $errput) = $ssh->capture2($command);
1296 $error .= "Error running $command: $errput " . $ssh->error . " "
1297 if $errput || $ssh->error;
1299 $error .= "Some clients may have successfully disconnected"
1300 if $error && (@$nas > 1);
1301 $error = "No clients found"
1303 die $error if $error;
1308 # class method to fetch groups/attributes from the sqlradius install on upgrade
1311 sub _upgrade_exporttype {
1312 # do this only if the radius_attr table is empty
1313 local $FS::radius_attr::noexport_hack = 1;
1315 return if qsearch('radius_attr', {});
1317 foreach my $self ($class->all_sqlradius) {
1318 my $error = $self->import_attrs;
1319 die "exportnum ".$self->exportnum.":\n$error\n" if $error;
1326 my $dbh = DBI->connect( map $self->option($_),
1327 qw( datasrc username password ) );
1329 warn "Error connecting to RADIUS server: $DBI::errstr\n";
1333 my $usergroup = $self->option('usergroup') || 'usergroup';
1335 warn "Importing RADIUS groups and attributes from ".$self->option('datasrc').
1338 # map out existing groups and attrs
1341 foreach my $radius_group ( qsearch('radius_group', {}) ) {
1342 $attrs_of{$radius_group->groupname} = +{
1343 map { $_->attrname => $_ } $radius_group->radius_attr
1345 $groupnum_of{$radius_group->groupname} = $radius_group->groupnum;
1348 # get groupnames from radgroupcheck and radgroupreply
1350 SELECT groupname, attribute, op, value, \'C\' FROM radgroupcheck
1352 SELECT groupname, attribute, op, value, \'R\' FROM radgroupreply';
1353 my @fixes; # things that need to be changed on the radius db
1354 foreach my $row ( @{ $dbh->selectall_arrayref($sql) } ) {
1355 my ($groupname, $attrname, $op, $value, $attrtype) = @$row;
1356 warn "$groupname.$attrname\n";
1357 if ( !exists($groupnum_of{$groupname}) ) {
1358 my $radius_group = new FS::radius_group {
1359 'groupname' => $groupname,
1362 $error = $radius_group->insert;
1364 warn "error inserting group $groupname: $error";
1365 next;#don't continue trying to insert the attribute
1367 $attrs_of{$groupname} = {};
1368 $groupnum_of{$groupname} = $radius_group->groupnum;
1371 my $a = $attrs_of{$groupname};
1372 my $old = $a->{$attrname};
1375 if ( $attrtype eq 'R' ) {
1376 # Freeradius tolerates illegal operators in reply attributes. We don't.
1377 if ( !grep ($_ eq $op, FS::radius_attr->ops('R')) ) {
1378 warn "$groupname.$attrname: changing $op to +=\n";
1379 # Make a note to change it in the db
1381 'UPDATE radgroupreply SET op = \'+=\' WHERE groupname = ? AND attribute = ? AND op = ? AND VALUE = ?',
1382 $groupname, $attrname, $op, $value
1384 # and import it correctly.
1389 if ( defined $old ) {
1391 $new = new FS::radius_attr {
1396 $error = $new->replace($old);
1398 warn "error modifying attr $attrname: $error";
1403 $new = new FS::radius_attr {
1404 'groupnum' => $groupnum_of{$groupname},
1405 'attrname' => $attrname,
1406 'attrtype' => $attrtype,
1410 $error = $new->insert;
1412 warn "error inserting attr $attrname: $error" if $error;
1416 $attrs_of{$groupname}->{$attrname} = $new;
1420 my ($sql, @args) = @$_;
1421 my $sth = $dbh->prepare($sql);
1422 $sth->execute(@args) or warn $sth->errstr;
1435 #don't just look for ->can('usage_sessions'), we're sqlradius-specific
1436 # (radiator is supposed to be setup with a radacct table)
1437 #i suppose it would be more slick to look for things that inherit from us..
1439 my @part_export = ();
1440 push @part_export, qsearch('part_export', { 'exporttype' => $_ } )
1441 foreach qw( sqlradius sqlradius_withdomain radiator phone_sqlradius
1442 broadband_sqlradius );
1446 sub all_sqlradius_withaccounting {
1448 grep { ! $_->option('ignore_accounting') } $class->all_sqlradius;