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 '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',
86 Real-time export of <b>radcheck</b>, <b>radreply</b> and <b>usergroup</b>/<b>radusergroup</b>
87 tables to any SQL database for
88 <a href="http://www.freeradius.org/">FreeRADIUS</a>
89 or <a href="http://radius.innercite.com/">ICRADIUS</a>.
93 An existing RADIUS database will be updated in realtime, but you can use
94 <a href="http://www.freeside.biz/mediawiki/index.php/Freeside:1.9:Documentation:Developer/bin/freeside-sqlradius-reset">freeside-sqlradius-reset</a>
95 to delete the entire RADIUS database and repopulate the tables from the
96 Freeside database. See the
97 <a href="http://search.cpan.org/dist/DBI/DBI.pm#connect">DBI documentation</a>
99 <a href="http://search.cpan.org/search?mode=module&query=DBD%3A%3A">documentation for your DBD</a>
100 for the exact syntax of a DBI data source.
102 <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.
103 <li>Using ICRADIUS, add a dummy "op" column to your database:
105 ALTER TABLE radcheck ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='<br>
106 ALTER TABLE radreply ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='<br>
107 ALTER TABLE radgroupcheck ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='<br>
108 ALTER TABLE radgroupreply ADD COLUMN op VARCHAR(2) NOT NULL DEFAULT '=='
110 <li>Using Radiator, see the
111 <a href="http://www.open.com.au/radiator/faq.html#38">Radiator FAQ</a>
112 for configuration information.
118 'desc' => 'Real-time export to SQL-backed RADIUS (FreeRADIUS, ICRADIUS)',
119 'options' => \%options,
122 'nas' => 'Y', # show export_nas selection in UI
123 'default_svc_class' => 'Internet',
125 'This export does not export RADIUS realms (see also '.
126 'sqlradius_withdomain). '.
130 sub _groups_susp_reason_map { map { reverse( /^\s*(\S+)\s*(.*)$/ ) }
131 split( "\n", shift->option('groups_susp_reason'));
134 sub rebless { shift; }
136 sub export_username { # override for other svcdb
137 my($self, $svc_acct) = (shift, shift);
138 warn "export_username called on $self with arg $svc_acct" if $DEBUG > 1;
142 sub radius_reply { #override for other svcdb
143 my($self, $svc_acct) = (shift, shift);
144 my %every = $svc_acct->EVERY::radius_reply;
145 map { @$_ } values %every;
148 sub radius_check { #override for other svcdb
149 my($self, $svc_acct) = (shift, shift);
150 my %every = $svc_acct->EVERY::radius_check;
151 map { @$_ } values %every;
155 my($self, $svc_x) = (shift, shift);
157 foreach my $table (qw(reply check)) {
158 my $method = "radius_$table";
159 my %attrib = $self->$method($svc_x);
160 next unless keys %attrib;
161 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'insert',
162 $table, $self->export_username($svc_x), %attrib );
163 return $err_or_queue unless ref($err_or_queue);
165 my @groups = $svc_x->radius_groups('hashref');
167 cluck localtime(). ": queuing usergroup_insert for ". $svc_x->svcnum.
168 " (". $self->export_username($svc_x). " with ". join(", ", @groups)
170 my $usergroup = $self->option('usergroup') || 'usergroup';
171 my $err_or_queue = $self->sqlradius_queue(
172 $svc_x->svcnum, 'usergroup_insert',
173 $self->export_username($svc_x), $usergroup, @groups );
174 return $err_or_queue unless ref($err_or_queue);
179 sub _export_replace {
180 my( $self, $new, $old ) = (shift, shift, shift);
182 local $SIG{HUP} = 'IGNORE';
183 local $SIG{INT} = 'IGNORE';
184 local $SIG{QUIT} = 'IGNORE';
185 local $SIG{TERM} = 'IGNORE';
186 local $SIG{TSTP} = 'IGNORE';
187 local $SIG{PIPE} = 'IGNORE';
189 my $oldAutoCommit = $FS::UID::AutoCommit;
190 local $FS::UID::AutoCommit = 0;
194 if ( $self->export_username($old) ne $self->export_username($new) ) {
195 my $usergroup = $self->option('usergroup') || 'usergroup';
196 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'rename',
197 $self->export_username($new), $self->export_username($old), $usergroup );
198 unless ( ref($err_or_queue) ) {
199 $dbh->rollback if $oldAutoCommit;
200 return $err_or_queue;
202 $jobnum = $err_or_queue->jobnum;
205 foreach my $table (qw(reply check)) {
206 my $method = "radius_$table";
207 my %new = $self->$method($new);
208 my %old = $self->$method($old);
209 if ( grep { !exists $old{$_} #new attributes
210 || $new{$_} ne $old{$_} #changed
213 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
214 $table, $self->export_username($new), %new );
215 unless ( ref($err_or_queue) ) {
216 $dbh->rollback if $oldAutoCommit;
217 return $err_or_queue;
220 my $error = $err_or_queue->depend_insert( $jobnum );
222 $dbh->rollback if $oldAutoCommit;
226 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
229 my @del = grep { !exists $new{$_} } keys %old;
231 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'attrib_delete',
232 $table, $self->export_username($new), @del );
233 unless ( ref($err_or_queue) ) {
234 $dbh->rollback if $oldAutoCommit;
235 return $err_or_queue;
238 my $error = $err_or_queue->depend_insert( $jobnum );
240 $dbh->rollback if $oldAutoCommit;
244 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
249 my (@oldgroups) = $old->radius_groups('hashref');
250 my (@newgroups) = $new->radius_groups('hashref');
251 ($error,$jobnum) = $self->sqlreplace_usergroups( $new->svcnum,
252 $self->export_username($new),
253 $jobnum ? $jobnum : '',
258 $dbh->rollback if $oldAutoCommit;
262 # radius database is used for authorization, so to avoid users reauthorizing
263 # before the database changes, disconnect users after changing database
264 if ($self->option('disconnect_ssh')) {
265 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'user_disconnect',
266 'disconnect_ssh' => $self->option('disconnect_ssh'),
267 'svc_acct_username' => $old->username,
268 'disconnect_port' => $self->option('disconnect_port'),
270 unless ( ref($err_or_queue) ) {
271 $dbh->rollback if $oldAutoCommit;
272 return $err_or_queue;
275 my $error = $err_or_queue->depend_insert( $jobnum );
277 $dbh->rollback if $oldAutoCommit;
283 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
288 #false laziness w/broadband_sqlradius.pm
289 sub _export_suspend {
290 my( $self, $svc_acct ) = (shift, shift);
292 my $new = $svc_acct->clone_suspended;
294 local $SIG{HUP} = 'IGNORE';
295 local $SIG{INT} = 'IGNORE';
296 local $SIG{QUIT} = 'IGNORE';
297 local $SIG{TERM} = 'IGNORE';
298 local $SIG{TSTP} = 'IGNORE';
299 local $SIG{PIPE} = 'IGNORE';
301 my $oldAutoCommit = $FS::UID::AutoCommit;
302 local $FS::UID::AutoCommit = 0;
307 my @newgroups = $self->suspended_usergroups($svc_acct);
309 unless (@newgroups) { #don't change password if assigning to a suspended group
311 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
312 'check', $self->export_username($new), $new->radius_check );
313 unless ( ref($err_or_queue) ) {
314 $dbh->rollback if $oldAutoCommit;
315 return $err_or_queue;
317 $jobnum = $err_or_queue->jobnum;
322 $self->sqlreplace_usergroups(
324 $self->export_username($new),
326 [ $svc_acct->radius_groups('hashref') ],
330 $dbh->rollback if $oldAutoCommit;
334 # radius database is used for authorization, so to avoid users reauthorizing
335 # before the database changes, disconnect users after changing database
336 if ($self->option('disconnect_ssh')) {
337 my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'user_disconnect',
338 'disconnect_ssh' => $self->option('disconnect_ssh'),
339 'svc_acct_username' => $svc_acct->username,
340 'disconnect_port' => $self->option('disconnect_port'),
342 unless ( ref($err_or_queue) ) {
343 $dbh->rollback if $oldAutoCommit;
344 return $err_or_queue;
347 my $error = $err_or_queue->depend_insert( $jobnum );
349 $dbh->rollback if $oldAutoCommit;
355 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
360 sub _export_unsuspend {
361 my( $self, $svc_x ) = (shift, shift);
363 local $SIG{HUP} = 'IGNORE';
364 local $SIG{INT} = 'IGNORE';
365 local $SIG{QUIT} = 'IGNORE';
366 local $SIG{TERM} = 'IGNORE';
367 local $SIG{TSTP} = 'IGNORE';
368 local $SIG{PIPE} = 'IGNORE';
370 my $oldAutoCommit = $FS::UID::AutoCommit;
371 local $FS::UID::AutoCommit = 0;
374 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'insert',
375 'check', $self->export_username($svc_x), $self->radius_check($svc_x) );
376 unless ( ref($err_or_queue) ) {
377 $dbh->rollback if $oldAutoCommit;
378 return $err_or_queue;
382 my (@oldgroups) = $self->suspended_usergroups($svc_x);
383 $error = $self->sqlreplace_usergroups(
385 $self->export_username($svc_x),
388 [ $svc_x->radius_groups('hashref') ],
391 $dbh->rollback if $oldAutoCommit;
394 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
400 my( $self, $svc_x ) = (shift, shift);
404 my $usergroup = $self->option('usergroup') || 'usergroup';
405 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'delete',
406 $self->export_username($svc_x), $usergroup );
407 $jobnum = $err_or_queue->jobnum;
409 # radius database is used for authorization, so to avoid users reauthorizing
410 # before the database changes, disconnect users after changing database
411 if ($self->option('disconnect_ssh')) {
412 my $err_or_queue = $self->sqlradius_queue( $svc_x->svcnum, 'user_disconnect',
413 'disconnect_ssh' => $self->option('disconnect_ssh'),
414 'svc_acct_username' => $svc_x->username,
415 'disconnect_port' => $self->option('disconnect_port'),
417 return $err_or_queue unless ref($err_or_queue);
419 my $error = $err_or_queue->depend_insert( $jobnum );
420 return $error if $error;
424 ref($err_or_queue) ? '' : $err_or_queue;
427 sub sqlradius_queue {
428 my( $self, $svcnum, $method ) = (shift, shift, shift);
430 my $queue = new FS::queue {
432 'job' => "FS::part_export::sqlradius::sqlradius_$method",
435 $self->option('datasrc'),
436 $self->option('username'),
437 $self->option('password'),
442 sub suspended_usergroups {
443 my ($self, $svc_x) = (shift, shift);
445 return () unless $svc_x;
447 my $svc_table = $svc_x->table;
449 #false laziness with FS::part_export::shellcommands
450 #subclass part_export?
452 my $r = $svc_x->cust_svc->cust_pkg->last_reason('susp');
453 my %reasonmap = $self->_groups_susp_reason_map;
456 $userspec = $reasonmap{$r->reasonnum}
457 if exists($reasonmap{$r->reasonnum});
458 $userspec = $reasonmap{$r->reason}
459 if (!$userspec && exists($reasonmap{$r->reason}));
462 if ( $userspec =~ /^\d+$/ ){
463 $suspend_svc = qsearchs( $svc_table, { 'svcnum' => $userspec } );
464 } elsif ( $userspec =~ /^\S+\@\S+$/ && $svc_table eq 'svc_acct' ){
465 my ($username,$domain) = split(/\@/, $userspec);
466 for my $user (qsearch( 'svc_acct', { 'username' => $username } )){
467 $suspend_svc = $user if $userspec eq $user->email;
469 }elsif ( $userspec && $svc_table eq 'svc_acct' ){
470 $suspend_svc = qsearchs( 'svc_acct', { 'username' => $userspec } );
473 return $suspend_svc->radius_groups('hashref') if $suspend_svc;
477 sub sqlradius_insert { #subroutine, not method
478 my $dbh = sqlradius_connect(shift, shift, shift);
479 my( $table, $username, %attributes ) = @_;
481 foreach my $attribute ( keys %attributes ) {
483 my $s_sth = $dbh->prepare(
484 "SELECT COUNT(*) FROM rad$table WHERE UserName = ? AND Attribute = ?"
485 ) or die $dbh->errstr;
486 $s_sth->execute( $username, $attribute ) or die $s_sth->errstr;
488 if ( $s_sth->fetchrow_arrayref->[0] ) {
490 my $u_sth = $dbh->prepare(
491 "UPDATE rad$table SET Value = ? WHERE UserName = ? AND Attribute = ?"
492 ) or die $dbh->errstr;
493 $u_sth->execute($attributes{$attribute}, $username, $attribute)
494 or die $u_sth->errstr;
498 my $i_sth = $dbh->prepare(
499 "INSERT INTO rad$table ( UserName, Attribute, op, Value ) ".
500 "VALUES ( ?, ?, ?, ? )"
501 ) or die $dbh->errstr;
505 ( $attribute eq 'Password' ? '==' : ':=' ),
506 $attributes{$attribute},
507 ) or die $i_sth->errstr;
515 sub sqlradius_usergroup_insert { #subroutine, not method
516 my $dbh = sqlradius_connect(shift, shift, shift);
517 my $username = shift;
518 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
521 my $s_sth = $dbh->prepare(
522 "SELECT COUNT(*) FROM $usergroup WHERE UserName = ? AND GroupName = ?"
523 ) or die $dbh->errstr;
525 my $sth = $dbh->prepare(
526 "INSERT INTO $usergroup ( UserName, GroupName, Priority ) VALUES ( ?, ?, ? )"
527 ) or die $dbh->errstr;
529 foreach ( @groups ) {
530 my $group = $_->{'groupname'};
531 my $priority = $_->{'priority'};
532 $s_sth->execute( $username, $group ) or die $s_sth->errstr;
533 if ($s_sth->fetchrow_arrayref->[0]) {
534 warn localtime() . ": sqlradius_usergroup_insert attempted to reinsert " .
535 "$group for $username\n"
539 $sth->execute( $username, $group, $priority )
540 or die "can't insert into groupname table: ". $sth->errstr;
542 if ( $s_sth->{Active} ) {
543 warn "sqlradius s_sth still active; calling ->finish()";
546 if ( $sth->{Active} ) {
547 warn "sqlradius sth still active; calling ->finish()";
553 sub sqlradius_usergroup_delete { #subroutine, not method
554 my $dbh = sqlradius_connect(shift, shift, shift);
555 my $username = shift;
556 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
559 my $sth = $dbh->prepare(
560 "DELETE FROM $usergroup WHERE UserName = ? AND GroupName = ?"
561 ) or die $dbh->errstr;
562 foreach ( @groups ) {
563 my $group = $_->{'groupname'};
564 $sth->execute( $username, $group )
565 or die "can't delete from groupname table: ". $sth->errstr;
570 sub sqlradius_rename { #subroutine, not method
571 my $dbh = sqlradius_connect(shift, shift, shift);
572 my($new_username, $old_username) = (shift, shift);
573 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
574 foreach my $table (qw(radreply radcheck), $usergroup ) {
575 my $sth = $dbh->prepare("UPDATE $table SET Username = ? WHERE UserName = ?")
577 $sth->execute($new_username, $old_username)
578 or die "can't update $table: ". $sth->errstr;
583 sub sqlradius_attrib_delete { #subroutine, not method
584 my $dbh = sqlradius_connect(shift, shift, shift);
585 my( $table, $username, @attrib ) = @_;
587 foreach my $attribute ( @attrib ) {
588 my $sth = $dbh->prepare(
589 "DELETE FROM rad$table WHERE UserName = ? AND Attribute = ?" )
591 $sth->execute($username,$attribute)
592 or die "can't delete from rad$table table: ". $sth->errstr;
597 sub sqlradius_delete { #subroutine, not method
598 my $dbh = sqlradius_connect(shift, shift, shift);
599 my $username = shift;
600 my $usergroup = ( $_[0] =~ /^(rad)?usergroup/i ) ? shift : 'usergroup';
602 foreach my $table (qw( radcheck radreply), $usergroup ) {
603 my $sth = $dbh->prepare( "DELETE FROM $table WHERE UserName = ?" );
604 $sth->execute($username)
605 or die "can't delete from $table table: ". $sth->errstr;
610 sub sqlradius_connect {
611 #my($datasrc, $username, $password) = @_;
612 #DBI->connect($datasrc, $username, $password) or die $DBI::errstr;
613 DBI->connect(@_) or die $DBI::errstr;
616 # on success, returns '' in scalar context, ('',$jobnum) in list context
617 # on error, always just returns error
618 sub sqlreplace_usergroups {
619 my ($self, $svcnum, $username, $jobnum, $old, $new) = @_;
621 # (sorta) false laziness with FS::svc_acct::replace
622 my @oldgroups = @$old;
623 my @newgroups = @$new;
625 foreach my $oldgroup ( @oldgroups ) {
626 if ( grep { $oldgroup eq $_ } @newgroups ) {
627 @newgroups = grep { $oldgroup ne $_ } @newgroups;
630 push @delgroups, $oldgroup;
633 my $usergroup = $self->option('usergroup') || 'usergroup';
636 my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_delete',
637 $username, $usergroup, @delgroups );
639 unless ref($err_or_queue);
641 my $error = $err_or_queue->depend_insert( $jobnum );
642 return $error if $error;
644 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
648 cluck localtime(). ": queuing usergroup_insert for $svcnum ($username) ".
649 "with ". join(", ", @newgroups)
651 my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_insert',
652 $username, $usergroup, @newgroups );
654 unless ref($err_or_queue);
656 my $error = $err_or_queue->depend_insert( $jobnum );
657 return $error if $error;
659 $jobnum = $err_or_queue->jobnum; # chain all of these dependencies
661 wantarray ? ('',$jobnum) : '';
667 =item usage_sessions HASHREF
669 =item usage_sessions TIMESTAMP_START TIMESTAMP_END [ SVC_ACCT [ IP [ PREFIX [ SQL_SELECT ] ] ] ]
671 New-style: pass a hashref with the following keys:
675 =item stoptime_start - Lower bound for AcctStopTime, as a UNIX timestamp
677 =item stoptime_end - Upper bound for AcctStopTime, as a UNIX timestamp
679 =item session_status - 'closed' to only show records with AcctStopTime,
680 'open' to only show records I<without> AcctStopTime, empty to show both.
682 =item starttime_start - Lower bound for AcctStartTime, as a UNIX timestamp
684 =item starttime_end - Upper bound for AcctStartTime, as a UNIX timestamp
696 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
697 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
700 SVC_ACCT, if specified, limits the results to the specified account.
702 IP, if specified, limits the results to the specified IP address.
704 PREFIX, if specified, limits the results to records with a matching
707 #SQL_SELECT defaults to * if unspecified. It can be useful to set it to
708 #SUM(acctsessiontime) or SUM(AcctInputOctets), etc.
710 Returns an arrayref of hashrefs with the following fields:
716 =item framedipaddress
722 =item acctsessiontime
724 =item acctinputoctets
726 =item acctoutputoctets
728 =item callingstationid
730 =item calledstationid
736 #some false laziness w/cust_svc::seconds_since_sqlradacct
742 my($start, $end, $svc_acct, $ip, $prefix) = ( '', '', '', '', '');
746 $start = $opt->{stoptime_start};
747 $end = $opt->{stoptime_end};
748 $svc_acct = $opt->{svc} || $opt->{svc_acct};
750 $prefix = $opt->{prefix};
751 $summarize = $opt->{summarize};
753 ( $start, $end ) = splice(@_, 0, 2);
754 $svc_acct = @_ ? shift : '';
755 $ip = @_ ? shift : '';
756 $prefix = @_ ? shift : '';
757 #my $select = @_ ? shift : '*';
762 return [] if $self->option('ignore_accounting');
764 my $dbh = sqlradius_connect( map $self->option($_),
765 qw( datasrc username password ) );
767 #select a unix time conversion function based on database type
768 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
771 qw( username realm framedipaddress
772 acctsessiontime acctinputoctets acctoutputoctets
773 callingstationid calledstationid
775 "$str2time acctstarttime ) as acctstarttime",
776 "$str2time acctstoptime ) as acctstoptime",
779 @fields = ( 'username', 'sum(acctsessiontime) as acctsessiontime', 'sum(acctinputoctets) as acctinputoctets',
780 'sum(acctoutputoctets) as acctoutputoctets',
787 my $username = $self->export_username($svc_acct);
788 if ( $username =~ /^([^@]+)\@([^@]+)$/ ) {
789 push @where, '( UserName = ? OR ( UserName = ? AND Realm = ? ) )';
790 push @param, $username, $1, $2;
792 push @where, 'UserName = ?';
793 push @param, $username;
797 if ($self->option('process_single_realm')) {
798 push @where, 'Realm = ?';
799 push @param, $self->option('realm');
803 push @where, ' FramedIPAddress = ?';
807 if ( length($prefix) ) {
808 #assume sip: for now, else things get ugly trying to match /^\w+:$prefix/
809 push @where, " CalledStationID LIKE 'sip:$prefix\%'";
812 my $acctstoptime = '';
813 if ( $opt->{session_status} ne 'open' ) {
815 $acctstoptime .= "$str2time AcctStopTime ) >= ?";
817 $acctstoptime .= ' AND ' if $end;
820 $acctstoptime .= "$str2time AcctStopTime ) <= ?";
824 if ( $opt->{session_status} ne 'closed' ) {
825 if ( $acctstoptime ) {
826 $acctstoptime = "( ( $acctstoptime ) OR AcctStopTime IS NULL )";
828 $acctstoptime = 'AcctStopTime IS NULL';
831 push @where, $acctstoptime;
833 if ( $opt->{starttime_start} ) {
834 push @where, "$str2time AcctStartTime ) >= ?";
835 push @param, $opt->{starttime_start};
837 if ( $opt->{starttime_end} ) {
838 push @where, "$str2time AcctStartTime ) <= ?";
839 push @param, $opt->{starttime_end};
842 my $where = join(' AND ', @where);
843 $where = "WHERE $where" if $where;
846 $groupby = 'GROUP BY username' if $summarize;
848 my $orderby = 'ORDER BY AcctStartTime DESC';
849 $orderby = '' if $summarize;
851 my $sql = 'SELECT '. join(', ', @fields).
852 " FROM radacct $where $groupby $orderby";
855 warn join(',', @param);
857 my $sth = $dbh->prepare($sql) or die $dbh->errstr;
858 $sth->execute(@param) or die $sth->errstr;
860 [ map { { %$_ } } @{ $sth->fetchall_arrayref({}) } ];
871 my $conf = new FS::Conf;
874 my $dbh = sqlradius_connect( map $self->option($_),
875 qw( datasrc username password ) );
877 my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
878 my @fields = qw( radacctid username realm acctsessiontime );
883 my $sth = $dbh->prepare("
884 SELECT RadAcctId, UserName, Realm, AcctSessionTime,
885 $str2time AcctStartTime), $str2time AcctStopTime),
886 AcctInputOctets, AcctOutputOctets
888 WHERE FreesideStatus IS NULL
889 AND AcctStopTime IS NOT NULL
890 ") or die $dbh->errstr;
891 $sth->execute() or die $sth->errstr;
893 while ( my $row = $sth->fetchrow_arrayref ) {
894 my($RadAcctId, $UserName, $Realm, $AcctSessionTime, $AcctStartTime,
895 $AcctStopTime, $AcctInputOctets, $AcctOutputOctets) = @$row;
896 warn "processing record: ".
897 "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s"
900 my $fs_username = $UserName;
902 $fs_username = lc($fs_username) unless $conf->exists('username-uppercase');
904 #my %search = ( 'username' => $fs_username );
907 my $errinfo = "for RADIUS detail RadAcctID $RadAcctId ".
908 "(UserName $UserName, Realm $Realm)";
911 if ( ref($self) =~ /withdomain/ ) { #well, should be a callback to that
916 } elsif ( $fs_username =~ /\@/ ) {
917 ($fs_username, $domain) = split('@', $fs_username);
919 warn 'WARNING: nothing Realm column and no @realm in UserName column '.
920 "$errinfo -- skipping\n" if $DEBUG;
921 $status = 'skipped (no realm)';
924 $extra_sql = " AND '$domain' = ( SELECT domain FROM svc_domain
925 WHERE svc_domain.svcnum = svc_acct.domsvc ) ";
928 my $oldAutoCommit = $FS::UID::AutoCommit; # can't undo side effects, but at
929 local $FS::UID::AutoCommit = 0; # least we can avoid over counting
935 if ( $self->option('process_single_realm')
936 && $self->option('realm') ne $Realm )
938 warn "WARNING: wrong realm $errinfo - skipping\n" if $DEBUG;
941 grep { qsearch( 'export_svc', { 'exportnum' => $self->exportnum,
942 'svcpart' => $_->cust_svc->svcpart,
947 { 'username' => $fs_username },
953 warn "WARNING: no svc_acct record found $errinfo - skipping\n";
954 } elsif ( scalar(@svc_acct) > 1 ) {
955 warn "WARNING: multiple svc_acct records found $errinfo - skipping\n";
958 my $svc_acct = $svc_acct[0];
959 warn "found svc_acct ". $svc_acct->svcnum. " $errinfo\n" if $DEBUG;
961 $svc_acct->last_login($AcctStartTime);
962 $svc_acct->last_logout($AcctStopTime);
964 my $session_time = $AcctStopTime;
965 $session_time = $AcctStartTime
966 if $self->option('ignore_long_sessions');
968 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
969 if ( $cust_pkg && $session_time < ( $cust_pkg->last_bill
970 || $cust_pkg->setup ) ) {
971 $status = 'skipped (too old)';
974 push @st, _try_decrement($svc_acct,'seconds', $AcctSessionTime);
975 push @st, _try_decrement($svc_acct,'upbytes', $AcctInputOctets);
976 push @st, _try_decrement($svc_acct,'downbytes', $AcctOutputOctets);
977 push @st, _try_decrement($svc_acct,'totalbytes', $AcctInputOctets
978 + $AcctOutputOctets);
979 $status=join(' ', @st);
986 warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG;
987 my $psth = $dbh->prepare("UPDATE radacct
988 SET FreesideStatus = ?
990 ) or die $dbh->errstr;
991 $psth->execute($status, $RadAcctId) or die $psth->errstr;
993 $fdbh->commit or die $fdbh->errstr if $oldAutoCommit;
1000 my ($svc_acct, $column, $amount) = @_;
1001 if ( $svc_acct->$column !~ /^$/ ) {
1002 warn " svc_acct.$column found (". $svc_acct->$column.
1003 ") - decrementing\n"
1005 my $method = 'decrement_' . $column;
1006 my $error = $svc_acct->$method($amount);
1007 die $error if $error;
1010 warn " no existing $column value for svc_acct - skipping\n" if $DEBUG;
1015 =item export_nas_insert NAS
1017 =item export_nas_delete NAS
1019 =item export_nas_replace NEW_NAS OLD_NAS
1021 Update the NAS table (allowed RADIUS clients) on the attached RADIUS
1022 server. Currently requires the table to be named 'nas' and to follow
1023 the stock schema (/etc/freeradius/nas.sql).
1027 sub export_nas_insert { shift->export_nas_action('insert', @_); }
1028 sub export_nas_delete { shift->export_nas_action('delete', @_); }
1029 sub export_nas_replace { shift->export_nas_action('replace', @_); }
1031 sub export_nas_action {
1033 my ($action, $new, $old) = @_;
1034 # find the NAS in the target table by its name
1035 my $nasname = ($action eq 'replace') ? $old->nasname : $new->nasname;
1036 my $nasnum = $new->nasnum;
1038 my $err_or_queue = $self->sqlradius_queue('', "nas_$action",
1039 nasname => $nasname,
1042 return $err_or_queue unless ref $err_or_queue;
1046 sub sqlradius_nas_insert {
1047 my $dbh = sqlradius_connect(shift, shift, shift);
1049 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
1050 or die "nasnum ".$opt{'nasnum'}.' not found';
1051 # insert actual NULLs where FS::Record has translated to empty strings
1052 my @values = map { length($nas->$_) ? $nas->$_ : undef }
1053 qw( nasname shortname type secret server community description );
1054 my $sth = $dbh->prepare('INSERT INTO nas
1055 (nasname, shortname, type, secret, server, community, description)
1056 VALUES (?, ?, ?, ?, ?, ?, ?)');
1057 $sth->execute(@values) or die $dbh->errstr;
1060 sub sqlradius_nas_delete {
1061 my $dbh = sqlradius_connect(shift, shift, shift);
1063 my $sth = $dbh->prepare('DELETE FROM nas WHERE nasname = ?');
1064 $sth->execute($opt{'nasname'}) or die $dbh->errstr;
1067 sub sqlradius_nas_replace {
1068 my $dbh = sqlradius_connect(shift, shift, shift);
1070 my $nas = qsearchs('nas', { nasnum => $opt{'nasnum'} })
1071 or die "nasnum ".$opt{'nasnum'}.' not found';
1072 my @values = map {$nas->$_}
1073 qw( nasname shortname type secret server community description );
1074 my $sth = $dbh->prepare('UPDATE nas SET
1075 nasname = ?, shortname = ?, type = ?, secret = ?,
1076 server = ?, community = ?, description = ?
1077 WHERE nasname = ?');
1078 $sth->execute(@values, $opt{'nasname'}) or die $dbh->errstr;
1081 =item export_attr_insert RADIUS_ATTR
1083 =item export_attr_delete RADIUS_ATTR
1085 =item export_attr_replace NEW_RADIUS_ATTR OLD_RADIUS_ATTR
1087 Update the group attribute tables (radgroupcheck and radgroupreply) on
1088 the RADIUS server. In delete and replace actions, the existing records
1089 are identified by the combination of group name and attribute name.
1091 In the special case where attributes are being replaced because a group
1092 name (L<FS::radius_group>->groupname) is changing, the pseudo-field
1093 'groupname' must be set in OLD_RADIUS_ATTR.
1097 # some false laziness with NAS export stuff...
1099 sub export_attr_insert { shift->export_attr_action('insert', @_); }
1101 sub export_attr_delete { shift->export_attr_action('delete', @_); }
1103 sub export_attr_replace { shift->export_attr_action('replace', @_); }
1105 sub export_attr_action {
1107 my ($action, $new, $old) = @_;
1110 if ( $action eq 'delete' ) {
1113 if ( $action eq 'delete' or $action eq 'replace' ) {
1114 # delete based on an exact match
1116 attrname => $old->attrname,
1117 attrtype => $old->attrtype,
1118 groupname => $old->groupname || $old->radius_group->groupname,
1120 value => $old->value,
1122 $err_or_queue = $self->sqlradius_queue('', 'attr_delete', %opt);
1123 return $err_or_queue unless ref $err_or_queue;
1125 # this probably doesn't matter, but just to be safe...
1126 my $jobnum = $err_or_queue->jobnum if $action eq 'replace';
1127 if ( $action eq 'replace' or $action eq 'insert' ) {
1129 attrname => $new->attrname,
1130 attrtype => $new->attrtype,
1131 groupname => $new->radius_group->groupname,
1133 value => $new->value,
1135 $err_or_queue = $self->sqlradius_queue('', 'attr_insert', %opt);
1136 $err_or_queue->depend_insert($jobnum) if $jobnum;
1137 return $err_or_queue unless ref $err_or_queue;
1142 sub sqlradius_attr_insert {
1143 my $dbh = sqlradius_connect(shift, shift, shift);
1147 # make sure $table is completely safe
1148 if ( $opt{'attrtype'} eq 'C' ) {
1149 $table = 'radgroupcheck';
1151 elsif ( $opt{'attrtype'} eq 'R' ) {
1152 $table = 'radgroupreply';
1155 die "unknown attribute type '$opt{attrtype}'";
1158 my @values = @opt{ qw(groupname attrname op value) };
1159 my $sth = $dbh->prepare(
1160 'INSERT INTO '.$table.' (groupname, attribute, op, value) VALUES (?,?,?,?)'
1162 $sth->execute(@values) or die $dbh->errstr;
1165 sub sqlradius_attr_delete {
1166 my $dbh = sqlradius_connect(shift, shift, shift);
1170 if ( $opt{'attrtype'} eq 'C' ) {
1171 $table = 'radgroupcheck';
1173 elsif ( $opt{'attrtype'} eq 'R' ) {
1174 $table = 'radgroupreply';
1177 die "unknown attribute type '".$opt{'attrtype'}."'";
1180 my @values = @opt{ qw(groupname attrname op value) };
1181 my $sth = $dbh->prepare(
1182 'DELETE FROM '.$table.
1183 ' WHERE groupname = ? AND attribute = ? AND op = ? AND value = ?'.
1186 $sth->execute(@values) or die $dbh->errstr;
1189 #sub sqlradius_attr_replace { no longer needed
1191 =item export_group_replace NEW OLD
1193 Replace the L<FS::radius_group> object OLD with NEW. This will change
1194 the group name and priority in all radusergroup records, and the group
1195 name in radgroupcheck and radgroupreply.
1199 sub export_group_replace {
1201 my ($new, $old) = @_;
1202 return '' if $new->groupname eq $old->groupname
1203 and $new->priority == $old->priority;
1205 my $err_or_queue = $self->sqlradius_queue(
1208 ($self->option('usergroup') || 'usergroup'),
1212 return $err_or_queue unless ref $err_or_queue;
1216 sub sqlradius_group_replace {
1217 my $dbh = sqlradius_connect(shift, shift, shift);
1218 my $usergroup = shift;
1219 $usergroup =~ /^(rad)?usergroup$/
1220 or die "bad usergroup table name: $usergroup";
1221 my ($new, $old) = (shift, shift);
1222 # apply renames to check/reply attribute tables
1223 if ( $new->{'groupname'} ne $old->{'groupname'} ) {
1224 foreach my $table (qw(radgroupcheck radgroupreply)) {
1225 my $sth = $dbh->prepare(
1226 'UPDATE '.$table.' SET groupname = ? WHERE groupname = ?'
1228 $sth->execute($new->{'groupname'}, $old->{'groupname'})
1229 or die $dbh->errstr;
1232 # apply renames and priority changes to usergroup table
1233 my $sth = $dbh->prepare(
1234 'UPDATE '.$usergroup.' SET groupname = ?, priority = ? WHERE groupname = ?'
1236 $sth->execute($new->{'groupname'}, $new->{'priority'}, $old->{'groupname'})
1237 or die $dbh->errstr;
1240 =item sqlradius_user_disconnect
1242 For a specified user, sends a disconnect request to all nas in the server database.
1244 Accepts L</sqlradius_connect> connection input and the following named parameters:
1246 I<disconnect_ssh> - user@host with access to radclient program (required)
1248 I<svc_acct_username> - the user to be disconnected (required)
1250 I<disconnect_port> - the port (on the nas) to send disconnect requests to (defaults to 1700)
1252 Note this is NOT the opposite of sqlradius_connect.
1256 sub sqlradius_user_disconnect {
1257 my $dbh = sqlradius_connect(shift, shift, shift);
1260 my $sth = $dbh->prepare('select nasname, secret from nas') or die $dbh->errstr;
1261 $sth->execute() or die $dbh->errstr;
1262 my $nas = $sth->fetchall_arrayref({});
1265 die "No nas found in radius db" unless @$nas;
1266 # set up ssh connection
1267 my $ssh = Net::OpenSSH->new($opt{'disconnect_ssh'});
1268 die "Couldn't establish SSH connection: " . $ssh->error
1270 # send individual disconnect requests
1271 my $user = $opt{'svc_acct_username'}; #svc_acct username
1272 my $port = $opt{'disconnect_port'} || 1700; #or should we pull this from the db?
1274 foreach my $nas (@$nas) {
1275 my $nasname = $nas->{'nasname'};
1276 my $secret = $nas->{'secret'};
1277 my $command = qq(echo "User-Name=$user" | radclient -r 1 $nasname:$port disconnect '$secret');
1278 my ($output, $errput) = $ssh->capture2($command);
1279 $error .= "Error running $command: $errput " . $ssh->error . " "
1280 if $errput || $ssh->error;
1282 $error .= "Some clients may have successfully disconnected"
1283 if $error && (@$nas > 1);
1284 $error = "No clients found"
1286 die $error if $error;
1291 # class method to fetch groups/attributes from the sqlradius install on upgrade
1294 sub _upgrade_exporttype {
1295 # do this only if the radius_attr table is empty
1296 local $FS::radius_attr::noexport_hack = 1;
1298 return if qsearch('radius_attr', {});
1300 foreach my $self ($class->all_sqlradius) {
1301 my $error = $self->import_attrs;
1302 die "exportnum ".$self->exportnum.":\n$error\n" if $error;
1309 my $dbh = DBI->connect( map $self->option($_),
1310 qw( datasrc username password ) );
1312 warn "Error connecting to RADIUS server: $DBI::errstr\n";
1316 my $usergroup = $self->option('usergroup') || 'usergroup';
1318 warn "Importing RADIUS groups and attributes from ".$self->option('datasrc').
1321 # map out existing groups and attrs
1324 foreach my $radius_group ( qsearch('radius_group', {}) ) {
1325 $attrs_of{$radius_group->groupname} = +{
1326 map { $_->attrname => $_ } $radius_group->radius_attr
1328 $groupnum_of{$radius_group->groupname} = $radius_group->groupnum;
1331 # get groupnames from radgroupcheck and radgroupreply
1333 SELECT groupname, attribute, op, value, \'C\' FROM radgroupcheck
1335 SELECT groupname, attribute, op, value, \'R\' FROM radgroupreply';
1336 my @fixes; # things that need to be changed on the radius db
1337 foreach my $row ( @{ $dbh->selectall_arrayref($sql) } ) {
1338 my ($groupname, $attrname, $op, $value, $attrtype) = @$row;
1339 warn "$groupname.$attrname\n";
1340 if ( !exists($groupnum_of{$groupname}) ) {
1341 my $radius_group = new FS::radius_group {
1342 'groupname' => $groupname,
1345 $error = $radius_group->insert;
1347 warn "error inserting group $groupname: $error";
1348 next;#don't continue trying to insert the attribute
1350 $attrs_of{$groupname} = {};
1351 $groupnum_of{$groupname} = $radius_group->groupnum;
1354 my $a = $attrs_of{$groupname};
1355 my $old = $a->{$attrname};
1358 if ( $attrtype eq 'R' ) {
1359 # Freeradius tolerates illegal operators in reply attributes. We don't.
1360 if ( !grep ($_ eq $op, FS::radius_attr->ops('R')) ) {
1361 warn "$groupname.$attrname: changing $op to +=\n";
1362 # Make a note to change it in the db
1364 'UPDATE radgroupreply SET op = \'+=\' WHERE groupname = ? AND attribute = ? AND op = ? AND VALUE = ?',
1365 $groupname, $attrname, $op, $value
1367 # and import it correctly.
1372 if ( defined $old ) {
1374 $new = new FS::radius_attr {
1379 $error = $new->replace($old);
1381 warn "error modifying attr $attrname: $error";
1386 $new = new FS::radius_attr {
1387 'groupnum' => $groupnum_of{$groupname},
1388 'attrname' => $attrname,
1389 'attrtype' => $attrtype,
1393 $error = $new->insert;
1395 warn "error inserting attr $attrname: $error" if $error;
1399 $attrs_of{$groupname}->{$attrname} = $new;
1403 my ($sql, @args) = @$_;
1404 my $sth = $dbh->prepare($sql);
1405 $sth->execute(@args) or warn $sth->errstr;
1418 #don't just look for ->can('usage_sessions'), we're sqlradius-specific
1419 # (radiator is supposed to be setup with a radacct table)
1420 #i suppose it would be more slick to look for things that inherit from us..
1422 my @part_export = ();
1423 push @part_export, qsearch('part_export', { 'exporttype' => $_ } )
1424 foreach qw( sqlradius sqlradius_withdomain radiator phone_sqlradius
1425 broadband_sqlradius );
1429 sub all_sqlradius_withaccounting {
1431 grep { ! $_->option('ignore_accounting') } $class->all_sqlradius;