X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2Fsvc_acct.pm;h=6a681ca89ed6bc5a654ea24afc3ddba028db85c3;hb=ad053ec7759bfb4f823abb0e8032e11b7491f8d2;hp=d806fe9bc1c6759235946519fb306affbf244ec1;hpb=f7ac8653683327aee6f5e825c49f09d751e0c352;p=freeside.git diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index d806fe9bc..6a681ca89 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -6,19 +6,24 @@ use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles $usernamemax $passwordmin $passwordmax $username_ampersand $username_letter $username_letterfirst $username_noperiod $username_nounderscore $username_nodash - $username_uppercase + $username_uppercase $username_percent $password_noampersand $password_noexclamation $welcome_template $welcome_from $welcome_subject $welcome_mimetype + $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 FS::UID qw( datasrc ); use FS::Conf; use FS::Record qw( qsearch qsearchs fields dbh dbdef ); +use FS::Msgcat qw(gettext); use FS::svc_Common; use FS::cust_svc; use FS::part_svc; @@ -30,14 +35,13 @@ use FS::queue; 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 @@ -56,6 +60,7 @@ $FS::UID::callback{'FS::svc_acct'} = sub { $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; @@ -73,6 +78,22 @@ $FS::UID::callback{'FS::svc_acct'} = sub { $welcome_subject = ''; $welcome_mimetype = ''; } + if ( $conf->exists('warning_email') ) { + $warning_template = new Text::Template ( + TYPE => 'ARRAY', + 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 { + $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'; @@ -165,6 +186,12 @@ FS::svc_Common. The following fields are currently supported: =item seconds - +=item upbytes - + +=item downbytes - + +=item totalbytes - + =item domsvc - svcnum from svc_domain =item radius_I - I (reply) @@ -183,8 +210,141 @@ Creates a new account. To add the account to the database, see L<"insert">. =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!POP number!, + 'popnum' => { + label => 'Access number', + type => 'select', + select_table => 'svc_acct_pop', + select_key => 'popnum', + select_label => 'city', + }, + 'username' => { + label => 'Username', + type => 'text', + disable_default => 1, + disable_fixed => 1, + }, + 'quota' => { + label => 'Quota', + type => 'text', + disable_inventory => 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 shells 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, + }, + '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, + }, + 'seconds' => { label => 'Seconds', + type => 'text', + disable_inventory => 1, + }, + }, + }; +} + 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, @@ -219,7 +379,11 @@ jobnum(s) (they will not run until the specific job(s) complete(s)). 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'; @@ -232,7 +396,7 @@ sub insert { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - $error = $self->check; + my $error = $self->check; return $error if $error; if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) { @@ -289,7 +453,10 @@ sub insert { if ( $cust_pkg ) { my $cust_main = $cust_pkg->cust_main; - 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); @@ -461,17 +628,25 @@ sub replace { 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 @@ -493,8 +668,10 @@ sub replace { 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}; @@ -675,7 +852,7 @@ sub check { my($recref) = $self->hashref; - my $x = $self->setfixed; + my $x = $self->setfixed( $self->_fieldhandlers ); return $x unless ref($x); my $part_svc = $x; @@ -688,16 +865,20 @@ sub check { #|| $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') ; 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; } @@ -725,6 +906,9 @@ sub check { if ( $password_noexclamation ) { $recref->{_password} =~ /\!/ and return gettext('illegal_password'); } + unless ( $username_percent ) { + $recref->{username} =~ /\%/ and return gettext('illegal_username'); + } $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum}; $recref->{popnum} = $1; @@ -746,6 +930,28 @@ sub check { if $recref->{uid} == 0 && $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. "\'; ". + $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}='' ); + } + + unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) { + $recref->{dir} =~ /^([\/\w\-\.\&]*)$/ or return "Illegal directory: ". $recref->{dir}; $recref->{dir} = $1; @@ -768,24 +974,6 @@ sub check { ; } - 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'); @@ -830,7 +1018,7 @@ sub check { unless ( $recref->{_password} ); #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) { - if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) { + 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 @@ -839,7 +1027,7 @@ sub check { #$recref->{password} = $1. # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))] #; - } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) { + } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) { $recref->{_password} = $1.$3; } elsif ( $recref->{_password} eq '*' ) { $recref->{_password} = '*'; @@ -888,6 +1076,9 @@ per export and with identical I values. 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; @@ -900,8 +1091,6 @@ sub _check_duplicate { return 'unknown svcpart '. $self->svcpart; } - my $global_unique = $conf->config('global_unique-username') || 'none'; - my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum } qsearch( 'svc_acct', { 'username' => $self->username } ); return gettext('username_in_use') @@ -1013,6 +1202,10 @@ expected to change in the future. sub radius_reply { my $self = shift; + + return %{ $self->{'radius_reply'} } + if exists $self->{'radius_reply'}; + my %reply = map { /^(radius_(.*))$/; @@ -1020,12 +1213,15 @@ sub radius_reply { #$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; } @@ -1042,22 +1238,75 @@ expected to change in the future. 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 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 +=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 { @@ -1075,6 +1324,8 @@ L). =cut +# FS::h_svc_acct has a history-aware svc_domain override + sub svc_domain { my $self = shift; $self->{'_domsvc'} @@ -1088,15 +1339,15 @@ Returns the FS::cust_svc record for this account (see L). =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 { @@ -1120,6 +1371,292 @@ sub acct_snarf { qsearch('acct_snarf', { 'svcnum' => $self->svcnum } ); } +=item decrement_upbytes OCTETS + +Decrements the I 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 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 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 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 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 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 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 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 ( $conf->exists("svc_acct-usage_$action") + && &{$op2condition{$op}}($self, $column, $amount) ) { + #my $error = $self->$action(); + my $error = $self->cust_svc->cust_pkg->$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; + 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 + ) + ) + ); + } + my $error = $self->replace; + die $error if $error; + + if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) { + my $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, @@ -1190,6 +1727,67 @@ sub get_session_history { $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 Returns all RADIUS groups for this account (see L). @@ -1199,6 +1797,8 @@ Returns all RADIUS groups for this account (see L). 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}; @@ -1239,7 +1839,7 @@ sub clone_kludge_unsuspend { =item check_password Checks the supplied password against the (possibly encrypted) password in the -database. Returns true for a sucessful authentication, false for no match. +database. Returns true for a successful authentication, false for no match. Currently supported encryptions are: classic DES crypt() and MD5 @@ -1289,13 +1889,15 @@ database. sub crypt_password { my $self = shift; - #false laziness w/shellcommands.pm #eventually should check a "password-encoding" field if ( length($self->_password) == 13 - || $self->_password =~ /^\$(1|2a?)\$/ ) { + || $self->_password =~ /^\$(1|2a?)\$/ + || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/ + ) + { $self->_password; } else { - my $encryption = scalar(@_) ? shift : 'crypt'; + my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt'; if ( $encryption eq 'crypt' ) { crypt( $self->_password, @@ -1304,13 +1906,67 @@ sub crypt_password { } elsif ( $encryption eq 'md5' ) { unix_md5_crypt( $self->_password ); } elsif ( $encryption eq 'blowfish' ) { - die "unknown encryption method $encryption"; + croak "unknown encryption method $encryption"; } else { - die "unknown encryption method $encryption"; + 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, "{CRYPT}94pAVyK/4oIBk" or +"{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f". + +The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it +to work the same as the B method. + +=cut + +sub ldap_password { + my $self = shift; + #eventually should check a "password-encoding" field + 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"; + } 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; + #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/ @@ -1484,6 +2140,82 @@ END $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, + $svc_acct->email, + ($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