package FS::svc_acct;
use strict;
-use vars qw( @ISA $DEBUG $me $conf
+use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
$dir_prefix @shells $usernamemin
$usernamemax $passwordmin $passwordmax
$username_ampersand $username_letter $username_letterfirst
$username_noperiod $username_nounderscore $username_nodash
- $username_uppercase
- $welcome_template $welcome_from $welcome_subject $welcome_mimetype
+ $username_uppercase $username_percent
+ $password_noampersand $password_noexclamation
+ $warning_template $warning_from $warning_subject $warning_mimetype
+ $warning_cc
$smtpmachine
$radius_password $radius_ip
$dirhash
@saltset @pw_set );
use Carp;
use Fcntl qw(:flock);
+use Date::Format;
+use Crypt::PasswdMD5 1.2;
+use Data::Dumper;
+use Authen::Passphrase;
use FS::UID qw( datasrc );
use FS::Conf;
use FS::Record qw( qsearch qsearchs fields dbh dbdef );
+use FS::Msgcat qw(gettext);
+use FS::UI::bytecount;
use FS::svc_Common;
use FS::cust_svc;
use FS::part_svc;
use FS::radius_usergroup;
use FS::export_svc;
use FS::part_export;
-use FS::Msgcat qw(gettext);
+use FS::svc_forward;
+use FS::svc_www;
+use FS::cdr;
@ISA = qw( FS::svc_Common );
$DEBUG = 0;
-#$DEBUG = 1;
$me = '[FS::svc_acct]';
#ask FS::UID to run this stuff for us later
$username_nodash = $conf->exists('username-nodash');
$username_uppercase = $conf->exists('username-uppercase');
$username_ampersand = $conf->exists('username-ampersand');
+ $username_percent = $conf->exists('username-percent');
+ $password_noampersand = $conf->exists('password-noexclamation');
+ $password_noexclamation = $conf->exists('password-noexclamation');
$dirhash = $conf->config('dirhash') || 0;
- if ( $conf->exists('welcome_email') ) {
- $welcome_template = new Text::Template (
+ if ( $conf->exists('warning_email') ) {
+ $warning_template = new Text::Template (
TYPE => 'ARRAY',
- SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
- ) or warn "can't create welcome email template: $Text::Template::ERROR";
- $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
- $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
- $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
+ SOURCE => [ map "$_\n", $conf->config('warning_email') ]
+ ) or warn "can't create warning email template: $Text::Template::ERROR";
+ $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
+ $warning_subject = $conf->config('warning_email-subject') || 'Warning';
+ $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
+ $warning_cc = $conf->config('warning_email-cc');
} else {
- $welcome_template = '';
- $welcome_from = '';
- $welcome_subject = '';
- $welcome_mimetype = '';
+ $warning_template = '';
+ $warning_from = '';
+ $warning_subject = '';
+ $warning_mimetype = '';
+ $warning_cc = '';
}
$smtpmachine = $conf->config('smtpmachine');
$radius_password = $conf->config('radius-password') || 'Password';
$radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
+ @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
};
@saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
=item _password - generated if blank
+=item _password_encoding - plain, crypt, ldap (or empty for autodetection)
+
=item sec_phrase - security phrase
=item popnum - Point of presence (see L<FS::svc_acct_pop>)
=item seconds -
+=item upbytes -
+
+=item downbytes -
+
+=item totalbytes -
+
=item domsvc - svcnum from svc_domain
-=item radius_I<Radius_Attribute> - I<Radius-Attribute>
+=item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
+
+=item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
=back
=cut
+sub table_info {
+ {
+ 'name' => 'Account',
+ 'longname_plural' => 'Access accounts and mailboxes',
+ 'sorts' => [ 'username', 'uid', ],
+ 'display_weight' => 10,
+ 'cancel_weight' => 50,
+ 'fields' => {
+ 'dir' => 'Home directory',
+ 'uid' => {
+ label => 'UID',
+ def_label => 'UID (set to fixed and blank for no UIDs)',
+ type => 'text',
+ },
+ 'slipip' => 'IP address',
+ # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
+ 'popnum' => {
+ label => 'Access number',
+ type => 'select',
+ select_table => 'svc_acct_pop',
+ select_key => 'popnum',
+ select_label => 'city',
+ disable_select => 1,
+ },
+ 'username' => {
+ label => 'Username',
+ type => 'text',
+ disable_default => 1,
+ disable_fixed => 1,
+ disable_select => 1,
+ },
+ 'quota' => {
+ label => 'Quota',
+ type => 'text',
+ disable_inventory => 1,
+ disable_select => 1,
+ },
+ '_password' => 'Password',
+ 'gid' => {
+ label => 'GID',
+ def_label => 'GID (when blank, defaults to UID)',
+ type => 'text',
+ },
+ 'shell' => {
+ #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
+ label => 'Shell',
+ def_label=> 'Shell (set to blank for no shell tracking)',
+ type =>'select',
+ select_list => [ $conf->config('shells') ],
+ disable_inventory => 1,
+ disable_select => 1,
+ },
+ 'finger' => 'Real name (GECOS)',
+ 'domsvc' => {
+ label => 'Domain',
+ #def_label => 'svcnum from svc_domain',
+ type => 'select',
+ select_table => 'svc_domain',
+ select_key => 'svcnum',
+ select_label => 'domain',
+ disable_inventory => 1,
+
+ },
+ 'usergroup' => {
+ label => 'RADIUS groups',
+ type => 'radius_usergroup_selector',
+ disable_inventory => 1,
+ disable_select => 1,
+ },
+ 'seconds' => { label => 'Seconds',
+ type => 'text',
+ disable_inventory => 1,
+ disable_select => 1,
+ },
+ 'upbytes' => { label => 'Upload',
+ type => 'text',
+ disable_inventory => 1,
+ disable_select => 1,
+ 'format' => \&FS::UI::bytecount::display_bytecount,
+ 'parse' => \&FS::UI::bytecount::parse_bytecount,
+ },
+ 'downbytes' => { label => 'Download',
+ type => 'text',
+ disable_inventory => 1,
+ disable_select => 1,
+ 'format' => \&FS::UI::bytecount::display_bytecount,
+ 'parse' => \&FS::UI::bytecount::parse_bytecount,
+ },
+ 'totalbytes'=> { label => 'Total up and download',
+ type => 'text',
+ disable_inventory => 1,
+ disable_select => 1,
+ 'format' => \&FS::UI::bytecount::display_bytecount,
+ 'parse' => \&FS::UI::bytecount::parse_bytecount,
+ },
+ 'seconds_threshold' => { label => 'Seconds',
+ type => 'text',
+ disable_inventory => 1,
+ disable_select => 1,
+ },
+ 'upbytes_threshold' => { label => 'Upload',
+ type => 'text',
+ disable_inventory => 1,
+ disable_select => 1,
+ 'format' => \&FS::UI::bytecount::display_bytecount,
+ 'parse' => \&FS::UI::bytecount::parse_bytecount,
+ },
+ 'downbytes_threshold' => { label => 'Download',
+ type => 'text',
+ disable_inventory => 1,
+ disable_select => 1,
+ 'format' => \&FS::UI::bytecount::display_bytecount,
+ 'parse' => \&FS::UI::bytecount::parse_bytecount,
+ },
+ 'totalbytes_threshold'=> { label => 'Total up and download',
+ type => 'text',
+ disable_inventory => 1,
+ disable_select => 1,
+ 'format' => \&FS::UI::bytecount::display_bytecount,
+ 'parse' => \&FS::UI::bytecount::parse_bytecount,
+ },
+ },
+ };
+}
+
sub table { 'svc_acct'; }
+sub _fieldhandlers {
+ {
+ #false laziness with edit/svc_acct.cgi
+ 'usergroup' => sub {
+ my( $self, $groups ) = @_;
+ if ( ref($groups) eq 'ARRAY' ) {
+ $groups;
+ } elsif ( length($groups) ) {
+ [ split(/\s*,\s*/, $groups) ];
+ } else {
+ [];
+ }
+ },
+ };
+}
+
+=item search_sql STRING
+
+Class method which returns an SQL fragment to search for the given string.
+
+=cut
+
+sub search_sql {
+ my( $class, $string ) = @_;
+ if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
+ my( $username, $domain ) = ( $1, $2 );
+ my $q_username = dbh->quote($username);
+ my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
+ if ( @svc_domain ) {
+ "svc_acct.username = $q_username AND ( ".
+ join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
+ " )";
+ } else {
+ '1 = 0'; #false
+ }
+ } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
+ ' ( '.
+ $class->search_sql_field('slipip', $string ).
+ ' OR '.
+ $class->search_sql_field('username', $string ).
+ ' ) ';
+ } else {
+ $class->search_sql_field('username', $string);
+ }
+}
+
+=item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
+
+Returns the "username@domain" string for this account.
+
+END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
+history records.
+
+=cut
+
+sub label {
+ my $self = shift;
+ $self->email(@_);
+}
+
+=cut
+
=item insert [ , OPTION => VALUE ... ]
Adds this account to the database. If there is an error, returns the error,
defined. An FS::cust_svc record will be created and inserted.
The additional field I<usergroup> can optionally be defined; if so it should
-contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
-sqlradius export only)
+contain an arrayref of group names. See L<FS::radius_usergroup>.
The additional field I<child_objects> can optionally be defined; if so it
should contain an arrayref of FS::tablename objects. They will have their
svcnum fields set and will be inserted after this record, but before any
-exports are run.
+exports are run. Each element of the array can also optionally be a
+two-element array reference containing the child object and the name of an
+alternate field to be filled in with the newly-inserted svcnum, for example
+C<[ $svc_forward, 'srcsvc' ]>
Currently available options are: I<depend_jobnum>
sub insert {
my $self = shift;
my %options = @_;
- my $error;
+
+ if ( $DEBUG ) {
+ warn "[$me] insert called on $self: ". Dumper($self).
+ "\nwith options: ". Dumper(%options);
+ }
local $SIG{HUP} = 'IGNORE';
local $SIG{INT} = 'IGNORE';
local $FS::UID::AutoCommit = 0;
my $dbh = dbh;
- $error = $self->check;
+ my $error = $self->check;
return $error if $error;
- #no, duplicate checking just got a whole lot more complicated
- #(perhaps keep this check with a config option to turn on?)
-
- #return gettext('username_in_use'). ": ". $self->username
- # if qsearchs( 'svc_acct', { 'username' => $self->username,
- # 'domsvc' => $self->domsvc,
- # } );
-
if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
unless ( $cust_svc ) {
$self->svcpart($cust_svc->svcpart);
}
- #new duplicate username checking
-
- my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
- unless ( $part_svc ) {
+ $error = $self->_check_duplicate;
+ if ( $error ) {
$dbh->rollback if $oldAutoCommit;
- return 'unknown svcpart '. $self->svcpart;
- }
-
- my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
- my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
- 'domsvc' => $self->domsvc } );
- my @dup_uid;
- if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
- && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
- @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
- } else {
- @dup_uid = ();
- }
-
- if ( @dup_user || @dup_userdomain || @dup_uid ) {
- my $exports = FS::part_export::export_info('svc_acct');
- my %conflict_user_svcpart;
- my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
-
- foreach my $part_export ( $part_svc->part_export ) {
-
- #this will catch to the same exact export
- my @svcparts = map { $_->svcpart }
- qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
-
- #this will catch to exports w/same exporthost+type ???
- #my @other_part_export = qsearch('part_export', {
- # 'machine' => $part_export->machine,
- # 'exporttype' => $part_export->exporttype,
- #} );
- #foreach my $other_part_export ( @other_part_export ) {
- # push @svcparts, map { $_->svcpart }
- # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
- #}
-
- #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
- #silly kludge to avoid uninitialized value errors
- my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
- ? $exports->{$part_export->exporttype}{'nodomain'}
- : '';
- if ( $nodomain =~ /^Y/i ) {
- $conflict_user_svcpart{$_} = $part_export->exportnum
- foreach @svcparts;
- } else {
- $conflict_userdomain_svcpart{$_} = $part_export->exportnum
- foreach @svcparts;
- }
- }
-
- foreach my $dup_user ( @dup_user ) {
- my $dup_svcpart = $dup_user->cust_svc->svcpart;
- if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
- $dbh->rollback if $oldAutoCommit;
- return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
- " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
- }
- }
-
- foreach my $dup_userdomain ( @dup_userdomain ) {
- my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
- if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
- $dbh->rollback if $oldAutoCommit;
- return "duplicate username\@domain: conflicts with svcnum ".
- $dup_userdomain->svcnum. " via exportnum ".
- $conflict_userdomain_svcpart{$dup_svcpart};
- }
- }
-
- foreach my $dup_uid ( @dup_uid ) {
- my $dup_svcpart = $dup_uid->cust_svc->svcpart;
- if ( exists($conflict_user_svcpart{$dup_svcpart})
- || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
- $dbh->rollback if $oldAutoCommit;
- return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
- "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
- || $conflict_userdomain_svcpart{$dup_svcpart};
- }
- }
-
+ return $error;
}
- #see? i told you it was more complicated
-
my @jobnums;
$error = $self->SUPER::insert(
'jobnums' => \@jobnums,
}
}
- #false laziness with sub replace (and cust_main)
- my $queue = new FS::queue {
- 'svcnum' => $self->svcnum,
- 'job' => 'FS::svc_acct::append_fuzzyfiles'
- };
- $error = $queue->insert($self->username);
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- return "queueing job (transaction rolled back): $error";
+ unless ( $skip_fuzzyfiles ) {
+ $error = $self->queue_fuzzyfiles_update;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "updating fuzzy search cache: $error";
+ }
}
my $cust_pkg = $self->cust_svc->cust_pkg;
if ( $cust_pkg ) {
my $cust_main = $cust_pkg->cust_main;
+ my $agentnum = $cust_main->agentnum;
- if ( $conf->exists('emailinvoiceauto') ) {
+ if ( $conf->exists('emailinvoiceautoalways')
+ || $conf->exists('emailinvoiceauto')
+ && ! $cust_main->invoicing_list_emailonly
+ ) {
my @invoicing_list = $cust_main->invoicing_list;
push @invoicing_list, $self->email;
$cust_main->invoicing_list(\@invoicing_list);
}
#welcome email
- my $to = '';
+ my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
+ = ('','','','','','');
+
+ if ( $conf->exists('welcome_email', $agentnum) ) {
+ $welcome_template = new Text::Template (
+ TYPE => 'ARRAY',
+ SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
+ ) or warn "can't create welcome email template: $Text::Template::ERROR";
+ $welcome_from = $conf->config('welcome_email-from', $agentnum);
+ # || 'your-isp-is-dum'
+ $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
+ || 'Welcome';
+ $welcome_subject_template = new Text::Template (
+ TYPE => 'STRING',
+ SOURCE => $welcome_subject,
+ ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
+ $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
+ || 'text/plain';
+ }
if ( $welcome_template && $cust_pkg ) {
- my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
+ my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
if ( $to ) {
+
+ my %hash = (
+ 'custnum' => $self->custnum,
+ 'username' => $self->username,
+ 'password' => $self->_password,
+ 'first' => $cust_main->first,
+ 'last' => $cust_main->getfield('last'),
+ 'pkg' => $cust_pkg->part_pkg->pkg,
+ );
my $wqueue = new FS::queue {
'svcnum' => $self->svcnum,
'job' => 'FS::svc_acct::send_email'
my $error = $wqueue->insert(
'to' => $to,
'from' => $welcome_from,
- 'subject' => $welcome_subject,
+ 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
'mimetype' => $welcome_mimetype,
- 'body' => $welcome_template->fill_in( HASH => {
- 'custnum' => $self->custnum,
- 'username' => $self->username,
- 'password' => $self->_password,
- 'first' => $cust_main->first,
- 'last' => $cust_main->getfield('last'),
- 'pkg' => $cust_pkg->part_pkg->pkg,
- } ),
+ 'body' => $welcome_template->fill_in( HASH => \%hash, ),
);
if ( $error ) {
$dbh->rollback if $oldAutoCommit;
if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
return "Can't delete an account with (svc_www) web service!"
- if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
+ if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
# what about records in session ? (they should refer to history table)
}
}
+ my $error = $self->SUPER::delete;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+
foreach my $radius_usergroup (
qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
) {
}
}
- my $error = $self->SUPER::delete;
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- return $error;
- }
-
$dbh->commit or die $dbh->errstr if $oldAutoCommit;
'';
}
returns the error, otherwise returns false.
The additional field I<usergroup> can optionally be defined; if so it should
-contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
-sqlradius export only)
+contain an arrayref of group names. See L<FS::radius_usergroup>.
+
=cut
my $error;
warn "$me replacing $old with $new\n" if $DEBUG;
+ # We absolutely have to have an old vs. new record to make this work.
+ if (!defined($old)) {
+ $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
+ }
+
return "can't modify system account" if $old->_check_system;
- return "Username in use"
- if $old->username ne $new->username &&
- qsearchs( 'svc_acct', { 'username' => $new->username,
- 'domsvc' => $new->domsvc,
- } );
{
#no warnings 'numeric'; #alas, a 5.006-ism
local($^W) = 0;
- return "Can't change uid!" if $old->uid != $new->uid;
+
+ foreach my $xid (qw( uid gid )) {
+
+ return "Can't change $xid!"
+ if ! $conf->exists("svc_acct-edit_$xid")
+ && $old->$xid() != $new->$xid()
+ && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
+ }
+
}
#change homdir when we change username
return $error if $error;
$old->usergroup( [ $old->radius_groups ] );
- warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
- warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
+ if ( $DEBUG ) {
+ warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
+ warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
+ }
if ( $new->usergroup ) {
#(sorta) false laziness with FS::part_export::sqlradius::_export_replace
my @newgroups = @{$new->usergroup};
}
+ if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
+ $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
+ $error = $new->_check_duplicate;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+ }
+
$error = $new->SUPER::replace($old);
if ( $error ) {
$dbh->rollback if $oldAutoCommit;
return $error if $error;
}
- if ( $new->username ne $old->username ) {
- #false laziness with sub insert (and cust_main)
- my $queue = new FS::queue {
- 'svcnum' => $new->svcnum,
- 'job' => 'FS::svc_acct::append_fuzzyfiles'
- };
- $error = $queue->insert($new->username);
+ if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
+ $error = $new->queue_fuzzyfiles_update;
if ( $error ) {
$dbh->rollback if $oldAutoCommit;
- return "queueing job (transaction rolled back): $error";
+ return "updating fuzzy search cache: $error";
}
}
''; #no error
}
+=item queue_fuzzyfiles_update
+
+Used by insert & replace to update the fuzzy search cache
+
+=cut
+
+sub queue_fuzzyfiles_update {
+ my $self = shift;
+
+ local $SIG{HUP} = 'IGNORE';
+ local $SIG{INT} = 'IGNORE';
+ local $SIG{QUIT} = 'IGNORE';
+ local $SIG{TERM} = 'IGNORE';
+ local $SIG{TSTP} = 'IGNORE';
+ local $SIG{PIPE} = 'IGNORE';
+
+ my $oldAutoCommit = $FS::UID::AutoCommit;
+ local $FS::UID::AutoCommit = 0;
+ my $dbh = dbh;
+
+ my $queue = new FS::queue {
+ 'svcnum' => $self->svcnum,
+ 'job' => 'FS::svc_acct::append_fuzzyfiles'
+ };
+ my $error = $queue->insert($self->username);
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "queueing job (transaction rolled back): $error";
+ }
+
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+ '';
+
+}
+
+
=item suspend
Suspends this account by calling export-specific suspend hooks. If there is
=item cancel
-Just returns false (no error) for now.
-
Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
+If the B<auto_unset_catchall> configuration option is set, this method will
+automatically remove any references to the canceled service in the catchall
+field of svc_domain. This allows packages that contain both a svc_domain and
+its catchall svc_acct to be canceled in one step.
+
+=cut
+
+sub cancel {
+ # Only one thing to do at this level
+ my $self = shift;
+ foreach my $svc_domain (
+ qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
+ if($conf->exists('auto_unset_catchall')) {
+ my %hash = $svc_domain->hash;
+ $hash{catchall} = '';
+ my $new = new FS::svc_domain ( \%hash );
+ my $error = $new->replace($svc_domain);
+ return $error if $error;
+ } else {
+ return "cannot unprovision svc_acct #".$self->svcnum.
+ " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
+ }
+ }
+
+ $self->SUPER::cancel;
+}
+
+
=item check
Checks all fields to make sure this is a valid service. If there is an error,
my($recref) = $self->hashref;
- my $x = $self->setfixed;
+ my $x = $self->setfixed( $self->_fieldhandlers );
return $x unless ref($x);
my $part_svc = $x;
#|| $self->ut_number('domsvc')
|| $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
|| $self->ut_textn('sec_phrase')
+ || $self->ut_snumbern('seconds')
+ || $self->ut_snumbern('upbytes')
+ || $self->ut_snumbern('downbytes')
+ || $self->ut_snumbern('totalbytes')
+ || $self->ut_enum( '_password_encoding',
+ [ '', qw( plain crypt ldap ) ]
+ )
;
return $error if $error;
my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
if ( $username_uppercase ) {
- $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
+ $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
$recref->{username} = $1;
} else {
- $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
+ $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
$recref->{username} = $1;
}
unless ( $username_ampersand ) {
$recref->{username} =~ /\&/ and return gettext('illegal_username');
}
+ unless ( $username_percent ) {
+ $recref->{username} =~ /\%/ and return gettext('illegal_username');
+ }
$recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
$recref->{popnum} = $1;
return "Only root can have uid 0"
if $recref->{uid} == 0
- && $recref->{username} ne 'root'
- && $recref->{username} ne 'toor';
+ && $recref->{username} !~ /^(root|toor|smtp)$/;
+
+ unless ( $recref->{username} eq 'sync' ) {
+ if ( grep $_ eq $recref->{shell}, @shells ) {
+ $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
+ } else {
+ return "Illegal shell \`". $self->shell. "\'; ".
+ "shells configuration value contains: @shells";
+ }
+ } else {
+ $recref->{shell} = '/bin/sync';
+ }
+
+ } else {
+ $recref->{gid} ne '' ?
+ return "Can't have gid without uid" : ( $recref->{gid}='' );
+ #$recref->{dir} ne '' ?
+ # return "Can't have directory without uid" : ( $recref->{dir}='' );
+ $recref->{shell} ne '' ?
+ return "Can't have shell without uid" : ( $recref->{shell}='' );
+ }
+ unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
$recref->{dir} =~ /^([\/\w\-\.\&]*)$/
or return "Illegal directory: ". $recref->{dir};
;
}
- unless ( $recref->{username} eq 'sync' ) {
- if ( grep $_ eq $recref->{shell}, @shells ) {
- $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
- } else {
- return "Illegal shell \`". $self->shell. "\'; ".
- $conf->dir. "/shells contains: @shells";
- }
- } else {
- $recref->{shell} = '/bin/sync';
- }
-
- } else {
- $recref->{gid} ne '' ?
- return "Can't have gid without uid" : ( $recref->{gid}='' );
- $recref->{dir} ne '' ?
- return "Can't have directory without uid" : ( $recref->{dir}='' );
- $recref->{shell} ne '' ?
- return "Can't have shell without uid" : ( $recref->{shell}='' );
}
# $error = $self->ut_textn('finger');
# return $error if $error;
+ if ( $self->getfield('finger') eq '' ) {
+ my $cust_pkg = $self->svcnum
+ ? $self->cust_svc->cust_pkg
+ : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
+ if ( $cust_pkg ) {
+ my $cust_main = $cust_pkg->cust_main;
+ $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
+ }
+ }
$self->getfield('finger') =~
/^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
or return "Illegal finger: ". $self->getfield('finger');
$self->ut_textn($_);
}
- #generate a password if it is blank
- $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
- unless ( $recref->{_password} );
-
- #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
- if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
- $recref->{_password} = $1.$3;
- #uncomment this to encrypt password immediately upon entry, or run
- #bin/crypt_pw in cron to give new users a window during which their
- #password is available to techs, for faxing, etc. (also be aware of
- #radius issues!)
- #$recref->{password} = $1.
- # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
- #;
- } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
- $recref->{_password} = $1.$3;
- } elsif ( $recref->{_password} eq '*' ) {
- $recref->{_password} = '*';
- } elsif ( $recref->{_password} eq '!' ) {
- $recref->{_password} = '!';
- } elsif ( $recref->{_password} eq '!!' ) {
- $recref->{_password} = '!!';
- } else {
- #return "Illegal password";
- return gettext('illegal_password'). " $passwordmin-$passwordmax ".
- FS::Msgcat::_gettext('illegal_password_characters').
- ": ". $recref->{_password};
- }
+ if ( $recref->{_password_encoding} eq 'ldap' ) {
- $self->SUPER::check;
-}
+ if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
+ $recref->{_password} = uc($1).$2;
+ } else {
+ return 'Illegal (ldap-encoded) password: '. $recref->{_password};
+ }
-=item _check_system
+ } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
-=cut
+ if ( $recref->{_password} =~
+ #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
+ /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
+ ) {
-sub _check_system {
- my $self = shift;
- scalar( grep { $self->username eq $_ || $self->email eq $_ }
- $conf->config('system_usernames')
- );
-}
+ $recref->{_password} = $1.$2;
-=item radius
+ } else {
+ return 'Illegal (crypt-encoded) password';
+ }
-Depriciated, use radius_reply instead.
+ } elsif ( $recref->{_password_encoding} eq 'plain' ) {
+
+ #generate a password if it is blank
+ $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
+ unless length( $recref->{_password} );
+
+ if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
+ $recref->{_password} = $1;
+ } else {
+ return gettext('illegal_password'). " $passwordmin-$passwordmax ".
+ FS::Msgcat::_gettext('illegal_password_characters').
+ ": ". $recref->{_password};
+ }
+
+ if ( $password_noampersand ) {
+ $recref->{_password} =~ /\&/ and return gettext('illegal_password');
+ }
+ if ( $password_noexclamation ) {
+ $recref->{_password} =~ /\!/ and return gettext('illegal_password');
+ }
+
+ } else {
+
+ #carp "warning: _password_encoding unspecified\n";
+
+ #generate a password if it is blank
+ unless ( length( $recref->{_password} ) ) {
+
+ $recref->{_password} =
+ join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
+ $recref->{_password_encoding} = 'plain';
+
+ } else {
+
+ #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
+ if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
+ $recref->{_password} = $1.$3;
+ $recref->{_password_encoding} = 'plain';
+ } elsif ( $recref->{_password} =~
+ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
+ ) {
+ $recref->{_password} = $1.$3;
+ $recref->{_password_encoding} = 'crypt';
+ } elsif ( $recref->{_password} eq '*' ) {
+ $recref->{_password} = '*';
+ $recref->{_password_encoding} = 'crypt';
+ } elsif ( $recref->{_password} eq '!' ) {
+ $recref->{_password_encoding} = 'crypt';
+ $recref->{_password} = '!';
+ } elsif ( $recref->{_password} eq '!!' ) {
+ $recref->{_password} = '!!';
+ $recref->{_password_encoding} = 'crypt';
+ } else {
+ #return "Illegal password";
+ return gettext('illegal_password'). " $passwordmin-$passwordmax ".
+ FS::Msgcat::_gettext('illegal_password_characters').
+ ": ". $recref->{_password};
+ }
+
+ }
+
+ }
+
+ $self->SUPER::check;
+
+}
+
+=item _check_system
+
+Internal function to check the username against the list of system usernames
+from the I<system_usernames> configuration value. Returns true if the username
+is listed on the system username list.
+
+=cut
+
+sub _check_system {
+ my $self = shift;
+ scalar( grep { $self->username eq $_ || $self->email eq $_ }
+ $conf->config('system_usernames')
+ );
+}
+
+=item _check_duplicate
+
+Internal function to check for duplicates usernames, username@domain pairs and
+uids.
+
+If the I<global_unique-username> configuration value is set to B<username> or
+B<username@domain>, enforces global username or username@domain uniqueness.
+
+In all cases, check for duplicate uids and usernames or username@domain pairs
+per export and with identical I<svcpart> values.
+
+=cut
+
+sub _check_duplicate {
+ my $self = shift;
+
+ my $global_unique = $conf->config('global_unique-username') || 'none';
+ return '' if $global_unique eq 'disabled';
+
+ #this is Pg-specific. what to do for mysql etc?
+ # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
+ warn "$me locking svc_acct table for duplicate search" if $DEBUG;
+ dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
+ or die dbh->errstr;
+ warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
+
+ my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
+ unless ( $part_svc ) {
+ return 'unknown svcpart '. $self->svcpart;
+ }
+
+ my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'username' => $self->username } );
+ return gettext('username_in_use')
+ if $global_unique eq 'username' && @dup_user;
+
+ my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'username' => $self->username,
+ 'domsvc' => $self->domsvc } );
+ return gettext('username_in_use')
+ if $global_unique eq 'username@domain' && @dup_userdomain;
+
+ my @dup_uid;
+ if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
+ && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
+ @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'uid' => $self->uid } );
+ } else {
+ @dup_uid = ();
+ }
+
+ if ( @dup_user || @dup_userdomain || @dup_uid ) {
+ my $exports = FS::part_export::export_info('svc_acct');
+ my %conflict_user_svcpart;
+ my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
+
+ foreach my $part_export ( $part_svc->part_export ) {
+
+ #this will catch to the same exact export
+ my @svcparts = map { $_->svcpart } $part_export->export_svc;
+
+ #this will catch to exports w/same exporthost+type ???
+ #my @other_part_export = qsearch('part_export', {
+ # 'machine' => $part_export->machine,
+ # 'exporttype' => $part_export->exporttype,
+ #} );
+ #foreach my $other_part_export ( @other_part_export ) {
+ # push @svcparts, map { $_->svcpart }
+ # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
+ #}
+
+ #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
+ #silly kludge to avoid uninitialized value errors
+ my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
+ ? $exports->{$part_export->exporttype}{'nodomain'}
+ : '';
+ if ( $nodomain =~ /^Y/i ) {
+ $conflict_user_svcpart{$_} = $part_export->exportnum
+ foreach @svcparts;
+ } else {
+ $conflict_userdomain_svcpart{$_} = $part_export->exportnum
+ foreach @svcparts;
+ }
+ }
+
+ foreach my $dup_user ( @dup_user ) {
+ my $dup_svcpart = $dup_user->cust_svc->svcpart;
+ if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
+ return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
+ " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
+ }
+ }
+
+ foreach my $dup_userdomain ( @dup_userdomain ) {
+ my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
+ if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
+ return "duplicate username\@domain: conflicts with svcnum ".
+ $dup_userdomain->svcnum. " via exportnum ".
+ $conflict_userdomain_svcpart{$dup_svcpart};
+ }
+ }
+
+ foreach my $dup_uid ( @dup_uid ) {
+ my $dup_svcpart = $dup_uid->cust_svc->svcpart;
+ if ( exists($conflict_user_svcpart{$dup_svcpart})
+ || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
+ return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
+ " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
+ || $conflict_userdomain_svcpart{$dup_svcpart};
+ }
+ }
+
+ }
+
+ return '';
+
+}
+
+=item radius
+
+Depriciated, use radius_reply instead.
=cut
sub radius_reply {
my $self = shift;
+
+ return %{ $self->{'radius_reply'} }
+ if exists $self->{'radius_reply'};
+
my %reply =
map {
/^(radius_(.*))$/;
#$attrib =~ s/_/\-/g;
( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
} grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
+
if ( $self->slipip && $self->slipip ne '0e0' ) {
$reply{$radius_ip} = $self->slipip;
}
+
+ if ( $self->seconds !~ /^$/ ) {
+ $reply{'Session-Timeout'} = $self->seconds;
+ }
+
%reply;
}
sub radius_check {
my $self = shift;
- my $password = $self->_password;
- my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
- ( $pw_attrib => $password,
+
+ return %{ $self->{'radius_check'} }
+ if exists $self->{'radius_check'};
+
+ my %check =
map {
/^(rc_(.*))$/;
my($column, $attrib) = ($1, $2);
#$attrib =~ s/_/\-/g;
( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
- } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
- );
+ } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
+
+ my $password = $self->_password;
+ my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
+
+ my $cust_svc = $self->cust_svc;
+ die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
+ unless $cust_svc;
+ my $cust_pkg = $cust_svc->cust_pkg;
+ if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
+ $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
+ }
+
+ %check;
+
}
-=item domain
+=item snapshot
+
+This method instructs the object to "snapshot" or freeze RADIUS check and
+reply attributes to the current values.
+
+=cut
+
+#bah, my english is too broken this morning
+#Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill. (This is used by
+#the FS::cust_pkg's replace method to trigger the correct export updates when
+#package dates change)
+
+sub snapshot {
+ my $self = shift;
+
+ $self->{$_} = { $self->$_() }
+ foreach qw( radius_reply radius_check );
+
+}
+
+=item forget_snapshot
+
+This methos instructs the object to forget any previously snapshotted
+RADIUS check and reply attributes.
+
+=cut
+
+sub forget_snapshot {
+ my $self = shift;
+
+ delete $self->{$_}
+ foreach qw( radius_reply radius_check );
+
+}
+
+=item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
Returns the domain associated with this account.
+END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
+history records.
+
=cut
sub domain {
my $self = shift;
die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
- my $svc_domain = $self->svc_domain
+ my $svc_domain = $self->svc_domain(@_)
or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
$svc_domain->domain;
}
=cut
+# FS::h_svc_acct has a history-aware svc_domain override
+
sub svc_domain {
my $self = shift;
$self->{'_domsvc'}
=cut
-sub cust_svc {
- my $self = shift;
- qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
-}
+#inherited from svc_Common
-=item email
+=item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
Returns an email address associated with the account.
+END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
+history records.
+
=cut
sub email {
my $self = shift;
- $self->username. '@'. $self->domain;
+ $self->username. '@'. $self->domain(@_);
}
=item acct_snarf
qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
}
+=item decrement_upbytes OCTETS
+
+Decrements the I<upbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub decrement_upbytes {
+ shift->_op_usage('-', 'upbytes', @_);
+}
+
+=item increment_upbytes OCTETS
+
+Increments the I<upbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub increment_upbytes {
+ shift->_op_usage('+', 'upbytes', @_);
+}
+
+=item decrement_downbytes OCTETS
+
+Decrements the I<downbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub decrement_downbytes {
+ shift->_op_usage('-', 'downbytes', @_);
+}
+
+=item increment_downbytes OCTETS
+
+Increments the I<downbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub increment_downbytes {
+ shift->_op_usage('+', 'downbytes', @_);
+}
+
+=item decrement_totalbytes OCTETS
+
+Decrements the I<totalbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub decrement_totalbytes {
+ shift->_op_usage('-', 'totalbytes', @_);
+}
+
+=item increment_totalbytes OCTETS
+
+Increments the I<totalbytes> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub increment_totalbytes {
+ shift->_op_usage('+', 'totalbytes', @_);
+}
+
+=item decrement_seconds SECONDS
+
+Decrements the I<seconds> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub decrement_seconds {
+ shift->_op_usage('-', 'seconds', @_);
+}
+
+=item increment_seconds SECONDS
+
+Increments the I<seconds> field of this record by the given amount. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub increment_seconds {
+ shift->_op_usage('+', 'seconds', @_);
+}
+
+
+my %op2action = (
+ '-' => 'suspend',
+ '+' => 'unsuspend',
+);
+my %op2condition = (
+ '-' => sub { my($self, $column, $amount) = @_;
+ $self->$column - $amount <= 0;
+ },
+ '+' => sub { my($self, $column, $amount) = @_;
+ $self->$column + $amount > 0;
+ },
+);
+my %op2warncondition = (
+ '-' => sub { my($self, $column, $amount) = @_;
+ my $threshold = $column . '_threshold';
+ $self->$column - $amount <= $self->$threshold + 0;
+ },
+ '+' => sub { my($self, $column, $amount) = @_;
+ $self->$column + $amount > 0;
+ },
+);
+
+sub _op_usage {
+ my( $self, $op, $column, $amount ) = @_;
+
+ warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
+ ' ('. $self->email. "): $op $amount\n"
+ if $DEBUG;
+
+ return '' unless $amount;
+
+ local $SIG{HUP} = 'IGNORE';
+ local $SIG{INT} = 'IGNORE';
+ local $SIG{QUIT} = 'IGNORE';
+ local $SIG{TERM} = 'IGNORE';
+ local $SIG{TSTP} = 'IGNORE';
+ local $SIG{PIPE} = 'IGNORE';
+
+ my $oldAutoCommit = $FS::UID::AutoCommit;
+ local $FS::UID::AutoCommit = 0;
+ my $dbh = dbh;
+
+ my $sql = "UPDATE svc_acct SET $column = ".
+ " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
+ " $op ? WHERE svcnum = ?";
+ warn "$me $sql\n"
+ if $DEBUG;
+
+ my $sth = $dbh->prepare( $sql )
+ or die "Error preparing $sql: ". $dbh->errstr;
+ my $rv = $sth->execute($amount, $self->svcnum);
+ die "Error executing $sql: ". $sth->errstr
+ unless defined($rv);
+ die "Can't update $column for svcnum". $self->svcnum
+ if $rv == 0;
+
+ my $action = $op2action{$op};
+
+ if ( &{$op2condition{$op}}($self, $column, $amount) ) {
+ foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
+ if ($part_export->option('overlimit_groups')) {
+ my ($new,$old);
+ my $other = new FS::svc_acct $self->hashref;
+ my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
+ ($self, $part_export->option('overlimit_groups'));
+ $other->usergroup( $groups );
+ if ($action eq 'suspend'){
+ $new = $other; $old = $self;
+ }else{
+ $new = $self; $old = $other;
+ }
+ my $error = $part_export->export_replace($new, $old);
+ $error ||= $self->overlimit($action);
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error replacing radius groups in export, ${op}: $error";
+ }
+ }
+ }
+ }
+
+ if ( $conf->exists("svc_acct-usage_$action")
+ && &{$op2condition{$op}}($self, $column, $amount) ) {
+ #my $error = $self->$action();
+ my $error = $self->cust_svc->cust_pkg->$action();
+ $error ||= $self->overlimit($action);
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error ${action}ing: $error";
+ }
+ }
+
+ if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
+ my $wqueue = new FS::queue {
+ 'svcnum' => $self->svcnum,
+ 'job' => 'FS::svc_acct::reached_threshold',
+ };
+
+ my $to = '';
+ if ($op eq '-'){
+ $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
+ }
+
+ # x_threshold race
+ my $error = $wqueue->insert(
+ 'svcnum' => $self->svcnum,
+ 'op' => $op,
+ 'column' => $column,
+ 'to' => $to,
+ );
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error queuing threshold activity: $error";
+ }
+ }
+
+ warn "$me update successful; committing\n"
+ if $DEBUG;
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+ '';
+
+}
+
+sub set_usage {
+ my( $self, $valueref ) = @_;
+
+ warn "$me set_usage called for svcnum ". $self->svcnum.
+ ' ('. $self->email. "): ".
+ join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
+ if $DEBUG;
+
+ local $SIG{HUP} = 'IGNORE';
+ local $SIG{INT} = 'IGNORE';
+ local $SIG{QUIT} = 'IGNORE';
+ local $SIG{TERM} = 'IGNORE';
+ local $SIG{TSTP} = 'IGNORE';
+ local $SIG{PIPE} = 'IGNORE';
+
+ local $FS::svc_Common::noexport_hack = 1;
+ my $oldAutoCommit = $FS::UID::AutoCommit;
+ local $FS::UID::AutoCommit = 0;
+ my $dbh = dbh;
+
+ my $reset = 0;
+ my %handyhash = ();
+ foreach my $field (keys %$valueref){
+ $reset = 1 if $valueref->{$field};
+ $self->setfield($field, $valueref->{$field});
+ $self->setfield( $field.'_threshold',
+ int($self->getfield($field)
+ * ( $conf->exists('svc_acct-usage_threshold')
+ ? 1 - $conf->config('svc_acct-usage_threshold')/100
+ : 0.20
+ )
+ )
+ );
+ $handyhash{$field} = $self->getfield($field);
+ $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
+ }
+ #my $error = $self->replace; #NO! we avoid the call to ->check for
+ #die $error if $error; #services not explicity changed via the UI
+
+ my $sql = "UPDATE svc_acct SET " .
+ join (',', map { "$_ = ?" } (keys %handyhash) ).
+ " WHERE svcnum = ?";
+
+ warn "$me $sql\n"
+ if $DEBUG;
+
+ if (scalar(keys %handyhash)) {
+ my $sth = $dbh->prepare( $sql )
+ or die "Error preparing $sql: ". $dbh->errstr;
+ my $rv = $sth->execute((grep{$_} values %handyhash), $self->svcnum);
+ die "Error executing $sql: ". $sth->errstr
+ unless defined($rv);
+ die "Can't update usage for svcnum ". $self->svcnum
+ if $rv == 0;
+ }
+
+ if ( $reset ) {
+ my $error = $self->overlimit('unsuspend');
+
+ foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
+ if ($part_export->option('overlimit_groups')) {
+ my $old = new FS::svc_acct $self->hashref;
+ my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
+ ($self, $part_export->option('overlimit_groups'));
+ $old->usergroup( $groups );
+ $error ||= $part_export->export_replace($self, $old);
+ }
+ }
+
+ if ( $conf->exists("svc_acct-usage_unsuspend")) {
+ $error ||= $self->cust_svc->cust_pkg->unsuspend;
+ }
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error unsuspending: $error";
+ }
+ }
+
+ warn "$me update successful; committing\n"
+ if $DEBUG;
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+ '';
+
+}
+
+
+=item recharge HASHREF
+
+ Increments usage columns by the amount specified in HASHREF as
+ column=>amount pairs.
+
+=cut
+
+sub recharge {
+ my ($self, $vhash) = @_;
+
+ if ( $DEBUG ) {
+ warn "[$me] recharge called on $self: ". Dumper($self).
+ "\nwith vhash: ". Dumper($vhash);
+ }
+
+ my $oldAutoCommit = $FS::UID::AutoCommit;
+ local $FS::UID::AutoCommit = 0;
+ my $dbh = dbh;
+ my $error = '';
+
+ foreach my $column (keys %$vhash){
+ $error ||= $self->_op_usage('+', $column, $vhash->{$column});
+ }
+
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ }else{
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+ }
+ return $error;
+}
+
+=item is_rechargeable
+
+Returns true if this svc_account can be "recharged" and false otherwise.
+
+=cut
+
+sub is_rechargable {
+ my $self = shift;
+ $self->seconds ne ''
+ || $self->upbytes ne ''
+ || $self->downbytes ne ''
+ || $self->totalbytes ne '';
+}
+
=item seconds_since TIMESTAMP
Returns the number of seconds this account has been online since TIMESTAMP,
$self->cust_svc->attribute_since_sqlradacct(@_);
}
-=item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
+=item get_session_history TIMESTAMP_START TIMESTAMP_END
Returns an array of hash references of this customers login history for the
given time range. (document this better)
=cut
-sub get_session_history_sqlradacct {
+sub get_session_history {
my $self = shift;
- $self->cust_svc->get_session_history_sqlradacct(@_);
+ $self->cust_svc->get_session_history(@_);
+}
+
+=item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
+
+=cut
+
+sub get_cdrs {
+ my($self, $start, $end, %opt ) = @_;
+
+ my $did = $self->username; #yup
+
+ my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
+
+ my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
+
+ #SELECT $for_update * FROM cdr
+ # WHERE calldate >= $start #need a conversion
+ # AND calldate < $end #ditto
+ # AND ( charged_party = "$did"
+ # OR charged_party = "$prefix$did" #if length($prefix);
+ # OR ( ( charged_party IS NULL OR charged_party = '' )
+ # AND
+ # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
+ # )
+ # )
+ # AND ( freesidestatus IS NULL OR freesidestatus = '' )
+
+ my $charged_or_src;
+ if ( length($prefix) ) {
+ $charged_or_src =
+ " AND ( charged_party = '$did'
+ OR charged_party = '$prefix$did'
+ OR ( ( charged_party IS NULL OR charged_party = '' )
+ AND
+ ( src = '$did' OR src = '$prefix$did' )
+ )
+ )
+ ";
+ } else {
+ $charged_or_src =
+ " AND ( charged_party = '$did'
+ OR ( ( charged_party IS NULL OR charged_party = '' )
+ AND
+ src = '$did'
+ )
+ )
+ ";
+
+ }
+
+ qsearch(
+ 'select' => "$for_update *",
+ 'table' => 'cdr',
+ 'hashref' => {
+ #( freesidestatus IS NULL OR freesidestatus = '' )
+ 'freesidestatus' => '',
+ },
+ 'extra_sql' => $charged_or_src,
+
+ );
+
}
=item radius_groups
sub radius_groups {
my $self = shift;
if ( $self->usergroup ) {
+ confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
+ unless ref($self->usergroup) eq 'ARRAY';
#when provisioning records, export callback runs in svc_Common.pm before
#radius_usergroup records can be inserted...
@{$self->usergroup};
new FS::svc_acct \%hash;
}
+=item check_password
+
+Checks the supplied password against the (possibly encrypted) password in the
+database. Returns true for a successful authentication, false for no match.
+
+Currently supported encryptions are: classic DES crypt() and MD5
+
+=cut
+
+sub check_password {
+ my($self, $check_password) = @_;
+
+ #remove old-style SUSPENDED kludge, they should be allowed to login to
+ #self-service and pay up
+ ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
+
+ if ( $self->_password_encoding eq 'ldap' ) {
+
+ my $auth = from_rfc2307 Authen::Passphrase $self->_password;
+ return $auth->match($check_password);
+
+ } elsif ( $self->_password_encoding eq 'crypt' ) {
+
+ my $auth = from_crypt Authen::Passphrase $self->_password;
+ return $auth->match($check_password);
+
+ } elsif ( $self->_password_encoding eq 'plain' ) {
+
+ return $check_password eq $password;
+
+ } else {
+
+ #XXX this could be replaced with Authen::Passphrase stuff
+
+ if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
+ return 0;
+ } elsif ( length($password) < 13 ) { #plaintext
+ $check_password eq $password;
+ } elsif ( length($password) == 13 ) { #traditional DES crypt
+ crypt($check_password, $password) eq $password;
+ } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
+ unix_md5_crypt($check_password, $password) eq $password;
+ } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
+ warn "Can't check password: Blowfish encryption not yet supported, ".
+ "svcnum ". $self->svcnum. "\n";
+ 0;
+ } else {
+ warn "Can't check password: Unrecognized encryption for svcnum ".
+ $self->svcnum. "\n";
+ 0;
+ }
+
+ }
+
+}
+
+=item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
+
+Returns an encrypted password, either by passing through an encrypted password
+in the database or by encrypting a plaintext password from the database.
+
+The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
+UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
+distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
+OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
+encryption type is only used if the password is not already encrypted in the
+database.
+
+=cut
+
+sub crypt_password {
+ my $self = shift;
+
+ if ( $self->_password_encoding eq 'ldap' ) {
+
+ if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
+ my $plain = $2;
+
+ #XXX this could be replaced with Authen::Passphrase stuff
+
+ my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
+ if ( $encryption eq 'crypt' ) {
+ crypt(
+ $self->_password,
+ $saltset[int(rand(64))].$saltset[int(rand(64))]
+ );
+ } elsif ( $encryption eq 'md5' ) {
+ unix_md5_crypt( $self->_password );
+ } elsif ( $encryption eq 'blowfish' ) {
+ croak "unknown encryption method $encryption";
+ } else {
+ croak "unknown encryption method $encryption";
+ }
+
+ } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
+ $1;
+ }
+
+ } elsif ( $self->_password_encoding eq 'crypt' ) {
+
+ return $self->_password;
+
+ } elsif ( $self->_password_encoding eq 'plain' ) {
+
+ #XXX this could be replaced with Authen::Passphrase stuff
+
+ my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
+ if ( $encryption eq 'crypt' ) {
+ crypt(
+ $self->_password,
+ $saltset[int(rand(64))].$saltset[int(rand(64))]
+ );
+ } elsif ( $encryption eq 'md5' ) {
+ unix_md5_crypt( $self->_password );
+ } elsif ( $encryption eq 'blowfish' ) {
+ croak "unknown encryption method $encryption";
+ } else {
+ croak "unknown encryption method $encryption";
+ }
+
+ } else {
+
+ if ( length($self->_password) == 13
+ || $self->_password =~ /^\$(1|2a?)\$/
+ || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
+ )
+ {
+ $self->_password;
+ } else {
+
+ #XXX this could be replaced with Authen::Passphrase stuff
+
+ my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
+ if ( $encryption eq 'crypt' ) {
+ crypt(
+ $self->_password,
+ $saltset[int(rand(64))].$saltset[int(rand(64))]
+ );
+ } elsif ( $encryption eq 'md5' ) {
+ unix_md5_crypt( $self->_password );
+ } elsif ( $encryption eq 'blowfish' ) {
+ croak "unknown encryption method $encryption";
+ } else {
+ croak "unknown encryption method $encryption";
+ }
+
+ }
+
+ }
+
+}
+
+=item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
+
+Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
+describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
+"{MD5}5426824942db4253f87a1009fd5d2d4".
+
+The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
+to work the same as the B</crypt_password> method.
+
+=cut
+
+sub ldap_password {
+ my $self = shift;
+ #eventually should check a "password-encoding" field
+
+ if ( $self->_password_encoding eq 'ldap' ) {
+
+ return $self->_password;
+
+ } elsif ( $self->_password_encoding eq 'crypt' ) {
+
+ if ( length($self->_password) == 13 ) { #crypt
+ return '{CRYPT}'. $self->_password;
+ } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
+ return '{MD5}'. $1;
+ #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
+ # die "Blowfish encryption not supported in this context, svcnum ".
+ # $self->svcnum. "\n";
+ } else {
+ warn "encryption method not (yet?) supported in LDAP context";
+ return '{CRYPT}*'; #unsupported, should not auth
+ }
+
+ } elsif ( $self->_password_encoding eq 'plain' ) {
+
+ return '{PLAIN}'. $self->_password;
+
+ #return '{CLEARTEXT}'. $self->_password; #?
+
+ } else {
+
+ if ( length($self->_password) == 13 ) { #crypt
+ return '{CRYPT}'. $self->_password;
+ } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
+ return '{MD5}'. $1;
+ } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
+ warn "Blowfish encryption not supported in this context, svcnum ".
+ $self->svcnum. "\n";
+ return '{CRYPT}*';
+
+ #are these two necessary anymore?
+ } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
+ return '{SSHA}'. $1;
+ } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
+ return '{NS-MTA-MD5}'. $1;
+
+ } else { #plaintext
+ return '{PLAIN}'. $self->_password;
+
+ #return '{CLEARTEXT}'. $self->_password; #?
+
+ #XXX this could be replaced with Authen::Passphrase stuff if it gets used
+ #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
+ #if ( $encryption eq 'crypt' ) {
+ # return '{CRYPT}'. crypt(
+ # $self->_password,
+ # $saltset[int(rand(64))].$saltset[int(rand(64))]
+ # );
+ #} elsif ( $encryption eq 'md5' ) {
+ # unix_md5_crypt( $self->_password );
+ #} elsif ( $encryption eq 'blowfish' ) {
+ # croak "unknown encryption method $encryption";
+ #} else {
+ # croak "unknown encryption method $encryption";
+ #}
+ }
+
+ }
+
+}
+
+=item domain_slash_username
+
+Returns $domain/$username/
+
+=cut
+
+sub domain_slash_username {
+ my $self = shift;
+ $self->domain. '/'. $self->username. '/';
+}
+
+=item virtual_maildir
+
+Returns $domain/maildirs/$username/
+
+=cut
+
+sub virtual_maildir {
+ my $self = shift;
+ $self->domain. '/maildirs/'. $self->username. '/';
+}
+
=back
=head1 SUBROUTINES
END
foreach my $group ( @all_groups ) {
- $html .= '<OPTION';
+ $html .= qq(<OPTION VALUE="$group");
if ( $sel_groups{$group} ) {
$html .= ' SELECTED';
$sel_groups{$group} = 0;
$html .= ">$group</OPTION>\n";
}
foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
- $html .= "<OPTION SELECTED>$group</OPTION>\n";
+ $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
};
$html .= '</SELECT>';
$html;
}
+=item reached_threshold
+
+Performs some activities when svc_acct thresholds (such as number of seconds
+remaining) are reached.
+
+=cut
+
+sub reached_threshold {
+ my %opt = @_;
+
+ my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
+ die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
+
+ if ( $opt{'op'} eq '+' ){
+ $svc_acct->setfield( $opt{'column'}.'_threshold',
+ int($svc_acct->getfield($opt{'column'})
+ * ( $conf->exists('svc_acct-usage_threshold')
+ ? $conf->config('svc_acct-usage_threshold')/100
+ : 0.80
+ )
+ )
+ );
+ my $error = $svc_acct->replace;
+ die $error if $error;
+ }elsif ( $opt{'op'} eq '-' ){
+
+ my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
+ return '' if ($threshold eq '' );
+
+ $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
+ my $error = $svc_acct->replace;
+ die $error if $error; # email next time, i guess
+
+ if ( $warning_template ) {
+ eval "use FS::Misc qw(send_email)";
+ die $@ if $@;
+
+ my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
+ my $cust_main = $cust_pkg->cust_main;
+
+ my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
+ $cust_main->invoicing_list,
+ ($opt{'to'} ? $opt{'to'} : ())
+ );
+
+ my $mimetype = $warning_mimetype;
+ $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
+
+ my $body = $warning_template->fill_in( HASH => {
+ 'custnum' => $cust_main->custnum,
+ 'username' => $svc_acct->username,
+ 'password' => $svc_acct->_password,
+ 'first' => $cust_main->first,
+ 'last' => $cust_main->getfield('last'),
+ 'pkg' => $cust_pkg->part_pkg->pkg,
+ 'column' => $opt{'column'},
+ 'amount' => $svc_acct->getfield($opt{'column'}),
+ 'threshold' => $threshold,
+ } );
+
+
+ my $error = send_email(
+ 'from' => $warning_from,
+ 'to' => $to,
+ 'subject' => $warning_subject,
+ 'content-type' => $mimetype,
+ 'body' => [ map "$_\n", split("\n", $body) ],
+ );
+ die $error if $error;
+ }
+ }else{
+ die "unknown op: " . $opt{'op'};
+ }
+}
+
=back
=head1 BUGS
projects / freeside.git / blobdiff