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 );
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} );
785 qw( username realm framedipaddress
786 acctsessiontime acctinputoctets acctoutputoctets
787 callingstationid calledstationid
789 "$str2time acctstarttime ) as acctstarttime",
790 "$str2time acctstoptime ) as acctstoptime",
793 @fields = ( 'username', 'sum(acctsessiontime) as acctsessiontime', 'sum(acctinputoctets) as acctinputoctets',
794 'sum(acctoutputoctets) as acctoutputoctets',
801 my $username = $self->export_username($svc_acct);
802 if ( $username =~ /^([^@]+)\@([^@]+)$/ ) {
803 push @where, '( UserName = ? OR ( UserName = ? AND Realm = ? ) )';
804 push @param, $username, $1, $2;
806 push @where, 'UserName = ?';
807 push @param, $username;
811 if ($self->option('process_single_realm')) {
812 push @where, 'Realm = ?';
813 push @param, $self->option('realm');
817 push @where, ' FramedIPAddress = ?';
821 if ( length($prefix) ) {
822 #assume sip: for now, else things get ugly trying to match /^\w+:$prefix/
823 push @where, " CalledStationID LIKE 'sip:$prefix\%'";
826 my $acctstoptime = '';
827 if ( $opt->{session_status} ne 'open' ) {
829 $acctstoptime .= "$str2time AcctStopTime ) >= ?";
831 $acctstoptime .= ' AND ' if $end;
834 $acctstoptime .= "$str2time AcctStopTime ) <= ?";
838 if ( $opt->{session_status} ne 'closed' ) {
839 if ( $acctstoptime ) {
840 $acctstoptime = "( ( $acctstoptime ) OR AcctStopTime IS NULL )";
842 $acctstoptime = 'AcctStopTime IS NULL';
845 push @where, $acctstoptime;
847 if ( $opt->{starttime_start} ) {
848 push @where, "$str2time AcctStartTime ) >= ?";
849 push @param, $opt->{starttime_start};
851 if ( $opt->{starttime_end} ) {
852 push @where, "$str2time AcctStartTime ) <= ?";
853 push @param, $opt->{starttime_end};
856 my $where = join(' AND ', @where);
857 $where = "WHERE $where" if $where;
860 $groupby = 'GROUP BY username' if $summarize;
862 my $orderby = 'ORDER BY AcctStartTime DESC';
863 $orderby = '' if $summarize;
865 my $sql = 'SELECT '. join(', ', @fields).
866 " FROM radacct $where $groupby $orderby";
869 warn join(',', @param);
871 my $sth = $dbh->prepare($sql) or die $dbh->errstr;
872 $sth->execute(@param) or die $sth->errstr;
874 [ map { { %$_ } } @{ $sth->fetchall_arrayref({}) } ];
885 my $conf = new FS::Conf;
888 my $dbh = sqlradius_connect( map $self->option($_),
889 qw( datasrc username password ) );
891 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
892 my @fields = qw( radacctid username realm acctsessiontime );
897 my $sth = $dbh->prepare("
898 SELECT RadAcctId, UserName, Realm, AcctSessionTime,
899 $str2time AcctStartTime), $str2time AcctStopTime),
900 AcctInputOctets, AcctOutputOctets
902 WHERE FreesideStatus IS NULL
903 AND AcctStopTime IS NOT NULL
904 ") or die $dbh->errstr;
905 $sth->execute() or die $sth->errstr;
907 while ( my $row = $sth->fetchrow_arrayref ) {
908 my($RadAcctId, $UserName, $Realm, $AcctSessionTime, $AcctStartTime,
909 $AcctStopTime, $AcctInputOctets, $AcctOutputOctets) = @$row;
910 warn "processing record: ".
911 "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s"
914 my $fs_username = $UserName;
916 $fs_username = lc($fs_username) unless $conf->exists('username-uppercase');
918 #my %search = ( 'username' => $fs_username );
921 my $errinfo = "for RADIUS detail RadAcctID $RadAcctId ".
922 "(UserName $UserName, Realm $Realm)";
925 if ( ref($self) =~ /withdomain/ ) { #well, should be a callback to that
930 } elsif ( $fs_username =~ /\@/ ) {
931 ($fs_username, $domain) = split('@', $fs_username);
933 warn 'WARNING: nothing Realm column and no @realm in UserName column '.
934 "$errinfo -- skipping\n" if $DEBUG;
935 $status = 'skipped (no realm)';
938 $extra_sql = " AND '$domain' = ( SELECT domain FROM svc_domain
939 WHERE svc_domain.svcnum = svc_acct.domsvc ) ";
942 my $oldAutoCommit = $FS::UID::AutoCommit; # can't undo side effects, but at
943 local $FS::UID::AutoCommit = 0; # least we can avoid over counting
949 if ( $self->option('process_single_realm')
950 && $self->option('realm') ne $Realm )
952 warn "WARNING: wrong realm $errinfo - skipping\n" if $DEBUG;
955 grep { qsearch( 'export_svc', { 'exportnum' => $self->exportnum,
956 'svcpart' => $_->cust_svc->svcpart,
961 { 'username' => $fs_username },
967 warn "WARNING: no svc_acct record found $errinfo - skipping\n";
968 } elsif ( scalar(@svc_acct) > 1 ) {
969 warn "WARNING: multiple svc_acct records found $errinfo - skipping\n";
972 my $svc_acct = $svc_acct[0];
973 warn "found svc_acct ". $svc_acct->svcnum. " $errinfo\n" if $DEBUG;
975 $svc_acct->last_login($AcctStartTime);
976 $svc_acct->last_logout($AcctStopTime);
978 my $session_time = $AcctStopTime;
979 $session_time = $AcctStartTime
980 if $self->option('ignore_long_sessions');
982 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
983 if ( $cust_pkg && $session_time < ( $cust_pkg->last_bill
984 || $cust_pkg->setup ) ) {
985 $status = 'skipped (too old)';
988 push @st, _try_decrement($svc_acct,'seconds', $AcctSessionTime);
989 push @st, _try_decrement($svc_acct,'upbytes', $AcctInputOctets);
990 push @st, _try_decrement($svc_acct,'downbytes', $AcctOutputOctets);
991 push @st, _try_decrement($svc_acct,'totalbytes', $AcctInputOctets
992 + $AcctOutputOctets);
993 $status=join(' ', @st);
1000 warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG;
1001 my $psth = $dbh->prepare("UPDATE radacct
1002 SET FreesideStatus = ?
1003 WHERE RadAcctId = ?"
1004 ) or die $dbh->errstr;
1005 $psth->execute($status, $RadAcctId) or die $psth->errstr;
1007 $fdbh->commit or die $fdbh->errstr if $oldAutoCommit;
1013 sub _try_decrement {
1014 my ($svc_acct, $column, $amount) = @_;
1015 if ( $svc_acct->$column !~ /^$/ ) {
1016 warn " svc_acct.$column found (". $svc_acct->$column.
1017 ") - decrementing\n"
1019 my $method = 'decrement_' . $column;
1020 my $error = $svc_acct->$method($amount);
1021 die $error if $error;
1024 warn " no existing $column value for svc_acct - skipping\n" if $DEBUG;
1029 =item export_nas_insert NAS
1031 =item export_nas_delete NAS
1033 =item export_nas_replace NEW_NAS OLD_NAS
1035 Update the NAS table (allowed RADIUS clients) on the attached RADIUS
1036 server. Currently requires the table to be named 'nas' and to follow
1037 the stock schema (/etc/freeradius/nas.sql).
1041 sub export_nas_insert { shift->export_nas_action('insert', @_); }
1042 sub export_nas_delete { shift->export_nas_action('delete', @_); }
1043 sub export_nas_replace { shift->export_nas_action('replace', @_); }
1045 sub export_nas_action {
1047 my ($action, $new, $old) = @_;
1048 # find the NAS in the target table by its name
1049 my $nasname = ($action eq 'replace') ? $old->nasname : $new->nasname;
1050 my $nasnum = $new->nasnum;
1052 my $err_or_queue = $self->sqlradius_queue('', "nas_$action",
1053 nasname => $nasname,
1056 return $err_or_queue unless ref $err_or_queue;
1060 sub sqlradius_nas_insert {
1061 my $dbh = sqlradius_connect(shift, shift, shift);
1063 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
1064 or die "nasnum ".$opt{'nasnum'}.' not found';
1065 # insert actual NULLs where FS::Record has translated to empty strings
1066 my @values = map { length($nas->$_) ? $nas->$_ : undef }
1067 qw( nasname shortname type secret server community description );
1068 my $sth = $dbh->prepare('INSERT INTO nas
1069 (nasname, shortname, type, secret, server, community, description)
1070 VALUES (?, ?, ?, ?, ?, ?, ?)');
1071 $sth->execute(@values) or die $dbh->errstr;
1074 sub sqlradius_nas_delete {
1075 my $dbh = sqlradius_connect(shift, shift, shift);
1077 my $sth = $dbh->prepare('DELETE FROM nas WHERE nasname = ?');
1078 $sth->execute($opt{'nasname'}) or die $dbh->errstr;
1081 sub sqlradius_nas_replace {
1082 my $dbh = sqlradius_connect(shift, shift, shift);
1084 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
1085 or die "nasnum ".$opt{'nasnum'}.' not found';
1086 my @values = map {$nas->$_}
1087 qw( nasname shortname type secret server community description );
1088 my $sth = $dbh->prepare('UPDATE nas SET
1089 nasname = ?, shortname = ?, type = ?, secret = ?,
1090 server = ?, community = ?, description = ?
1091 WHERE nasname = ?');
1092 $sth->execute(@values, $opt{'nasname'}) or die $dbh->errstr;
1095 =item export_attr_insert RADIUS_ATTR
1097 =item export_attr_delete RADIUS_ATTR
1099 =item export_attr_replace NEW_RADIUS_ATTR OLD_RADIUS_ATTR
1101 Update the group attribute tables (radgroupcheck and radgroupreply) on
1102 the RADIUS server. In delete and replace actions, the existing records
1103 are identified by the combination of group name and attribute name.
1105 In the special case where attributes are being replaced because a group
1106 name (L<FS::radius_group>->groupname) is changing, the pseudo-field
1107 'groupname' must be set in OLD_RADIUS_ATTR.
1111 # some false laziness with NAS export stuff...
1113 sub export_attr_insert { shift->export_attr_action('insert', @_); }
1115 sub export_attr_delete { shift->export_attr_action('delete', @_); }
1117 sub export_attr_replace { shift->export_attr_action('replace', @_); }
1119 sub export_attr_action {
1121 my ($action, $new, $old) = @_;
1124 if ( $action eq 'delete' ) {
1127 if ( $action eq 'delete' or $action eq 'replace' ) {
1128 # delete based on an exact match
1130 attrname => $old->attrname,
1131 attrtype => $old->attrtype,
1132 groupname => $old->groupname || $old->radius_group->groupname,
1134 value => $old->value,
1136 $err_or_queue = $self->sqlradius_queue('', 'attr_delete', %opt);
1137 return $err_or_queue unless ref $err_or_queue;
1139 # this probably doesn't matter, but just to be safe...
1140 my $jobnum = $err_or_queue->jobnum if $action eq 'replace';
1141 if ( $action eq 'replace' or $action eq 'insert' ) {
1143 attrname => $new->attrname,
1144 attrtype => $new->attrtype,
1145 groupname => $new->radius_group->groupname,
1147 value => $new->value,
1149 $err_or_queue = $self->sqlradius_queue('', 'attr_insert', %opt);
1150 $err_or_queue->depend_insert($jobnum) if $jobnum;
1151 return $err_or_queue unless ref $err_or_queue;
1156 sub sqlradius_attr_insert {
1157 my $dbh = sqlradius_connect(shift, shift, shift);
1161 # make sure $table is completely safe
1162 if ( $opt{'attrtype'} eq 'C' ) {
1163 $table = 'radgroupcheck';
1165 elsif ( $opt{'attrtype'} eq 'R' ) {
1166 $table = 'radgroupreply';
1169 die "unknown attribute type '$opt{attrtype}'";
1172 my @values = @opt{ qw(groupname attrname op value) };
1173 my $sth = $dbh->prepare(
1174 'INSERT INTO '.$table.' (groupname, attribute, op, value) VALUES (?,?,?,?)'
1176 $sth->execute(@values) or die $dbh->errstr;
1179 sub sqlradius_attr_delete {
1180 my $dbh = sqlradius_connect(shift, shift, shift);
1184 if ( $opt{'attrtype'} eq 'C' ) {
1185 $table = 'radgroupcheck';
1187 elsif ( $opt{'attrtype'} eq 'R' ) {
1188 $table = 'radgroupreply';
1191 die "unknown attribute type '".$opt{'attrtype'}."'";
1194 my @values = @opt{ qw(groupname attrname op value) };
1195 my $sth = $dbh->prepare(
1196 'DELETE FROM '.$table.
1197 ' WHERE groupname = ? AND attribute = ? AND op = ? AND value = ?'.
1200 $sth->execute(@values) or die $dbh->errstr;
1203 #sub sqlradius_attr_replace { no longer needed
1205 =item export_group_replace NEW OLD
1207 Replace the L<FS::radius_group> object OLD with NEW. This will change
1208 the group name and priority in all radusergroup records, and the group
1209 name in radgroupcheck and radgroupreply.
1213 sub export_group_replace {
1215 my ($new, $old) = @_;
1216 return '' if $new->groupname eq $old->groupname
1217 and $new->priority == $old->priority;
1219 my $err_or_queue = $self->sqlradius_queue(
1222 ($self->option('usergroup') || 'usergroup'),
1226 return $err_or_queue unless ref $err_or_queue;
1230 sub sqlradius_group_replace {
1231 my $dbh = sqlradius_connect(shift, shift, shift);
1232 my $usergroup = shift;
1233 $usergroup =~ /^(rad)?usergroup$/
1234 or die "bad usergroup table name: $usergroup";
1235 my ($new, $old) = (shift, shift);
1236 # apply renames to check/reply attribute tables
1237 if ( $new->{'groupname'} ne $old->{'groupname'} ) {
1238 foreach my $table (qw(radgroupcheck radgroupreply)) {
1239 my $sth = $dbh->prepare(
1240 'UPDATE '.$table.' SET groupname = ? WHERE groupname = ?'
1242 $sth->execute($new->{'groupname'}, $old->{'groupname'})
1243 or die $dbh->errstr;
1246 # apply renames and priority changes to usergroup table
1247 my $sth = $dbh->prepare(
1248 'UPDATE '.$usergroup.' SET groupname = ?, priority = ? WHERE groupname = ?'
1250 $sth->execute($new->{'groupname'}, $new->{'priority'}, $old->{'groupname'})
1251 or die $dbh->errstr;
1254 =item sqlradius_user_disconnect
1256 For a specified user, sends a disconnect request to all nas in the server database.
1258 Accepts L</sqlradius_connect> connection input and the following named parameters:
1260 I<disconnect_ssh> - user@host with access to radclient program (required)
1262 I<svc_acct_username> - the user to be disconnected (required)
1264 I<disconnect_port> - the port (on the nas) to send disconnect requests to (defaults to 1700)
1266 Note this is NOT the opposite of sqlradius_connect.
1270 sub sqlradius_user_disconnect {
1271 my $dbh = sqlradius_connect(shift, shift, shift);
1274 my $sth = $dbh->prepare('select nasname, secret from nas') or die $dbh->errstr;
1275 $sth->execute() or die $dbh->errstr;
1276 my $nas = $sth->fetchall_arrayref({});
1279 die "No nas found in radius db" unless @$nas;
1280 # set up ssh connection
1281 my $ssh = Net::OpenSSH->new($opt{'disconnect_ssh'});
1282 die "Couldn't establish SSH connection: " . $ssh->error
1284 # send individual disconnect requests
1285 my $user = $opt{'svc_acct_username'}; #svc_acct username
1286 my $port = $opt{'disconnect_port'} || 1700; #or should we pull this from the db?
1288 foreach my $nas (@$nas) {
1289 my $nasname = $nas->{'nasname'};
1290 my $secret = $nas->{'secret'};
1291 my $command = qq(echo "User-Name=$user" | radclient -r 1 $nasname:$port disconnect '$secret');
1292 my ($output, $errput) = $ssh->capture2($command);
1293 $error .= "Error running $command: $errput " . $ssh->error . " "
1294 if $errput || $ssh->error;
1296 $error .= "Some clients may have successfully disconnected"
1297 if $error && (@$nas > 1);
1298 $error = "No clients found"
1300 die $error if $error;
1305 # class method to fetch groups/attributes from the sqlradius install on upgrade
1308 sub _upgrade_exporttype {
1309 # do this only if the radius_attr table is empty
1310 local $FS::radius_attr::noexport_hack = 1;
1312 return if qsearch('radius_attr', {});
1314 foreach my $self ($class->all_sqlradius) {
1315 my $error = $self->import_attrs;
1316 die "exportnum ".$self->exportnum.":\n$error\n" if $error;
1323 my $dbh = DBI->connect( map $self->option($_),
1324 qw( datasrc username password ) );
1326 warn "Error connecting to RADIUS server: $DBI::errstr\n";
1330 my $usergroup = $self->option('usergroup') || 'usergroup';
1332 warn "Importing RADIUS groups and attributes from ".$self->option('datasrc').
1335 # map out existing groups and attrs
1338 foreach my $radius_group ( qsearch('radius_group', {}) ) {
1339 $attrs_of{$radius_group->groupname} = +{
1340 map { $_->attrname => $_ } $radius_group->radius_attr
1342 $groupnum_of{$radius_group->groupname} = $radius_group->groupnum;
1345 # get groupnames from radgroupcheck and radgroupreply
1347 SELECT groupname, attribute, op, value, \'C\' FROM radgroupcheck
1349 SELECT groupname, attribute, op, value, \'R\' FROM radgroupreply';
1350 my @fixes; # things that need to be changed on the radius db
1351 foreach my $row ( @{ $dbh->selectall_arrayref($sql) } ) {
1352 my ($groupname, $attrname, $op, $value, $attrtype) = @$row;
1353 warn "$groupname.$attrname\n";
1354 if ( !exists($groupnum_of{$groupname}) ) {
1355 my $radius_group = new FS::radius_group {
1356 'groupname' => $groupname,
1359 $error = $radius_group->insert;
1361 warn "error inserting group $groupname: $error";
1362 next;#don't continue trying to insert the attribute
1364 $attrs_of{$groupname} = {};
1365 $groupnum_of{$groupname} = $radius_group->groupnum;
1368 my $a = $attrs_of{$groupname};
1369 my $old = $a->{$attrname};
1372 if ( $attrtype eq 'R' ) {
1373 # Freeradius tolerates illegal operators in reply attributes. We don't.
1374 if ( !grep ($_ eq $op, FS::radius_attr->ops('R')) ) {
1375 warn "$groupname.$attrname: changing $op to +=\n";
1376 # Make a note to change it in the db
1378 'UPDATE radgroupreply SET op = \'+=\' WHERE groupname = ? AND attribute = ? AND op = ? AND VALUE = ?',
1379 $groupname, $attrname, $op, $value
1381 # and import it correctly.
1386 if ( defined $old ) {
1388 $new = new FS::radius_attr {
1393 $error = $new->replace($old);
1395 warn "error modifying attr $attrname: $error";
1400 $new = new FS::radius_attr {
1401 'groupnum' => $groupnum_of{$groupname},
1402 'attrname' => $attrname,
1403 'attrtype' => $attrtype,
1407 $error = $new->insert;
1409 warn "error inserting attr $attrname: $error" if $error;
1413 $attrs_of{$groupname}->{$attrname} = $new;
1417 my ($sql, @args) = @$_;
1418 my $sth = $dbh->prepare($sql);
1419 $sth->execute(@args) or warn $sth->errstr;
1432 #don't just look for ->can('usage_sessions'), we're sqlradius-specific
1433 # (radiator is supposed to be setup with a radacct table)
1434 #i suppose it would be more slick to look for things that inherit from us..
1436 my @part_export = ();
1437 push @part_export, qsearch('part_export', { 'exporttype' => $_ } )
1438 foreach qw( sqlradius sqlradius_withdomain radiator phone_sqlradius
1439 broadband_sqlradius );
1443 sub all_sqlradius_withaccounting {
1445 grep { ! $_->option('ignore_accounting') } $class->all_sqlradius;