X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2Fsvc_acct.pm;h=8c1c350fa08d2dd1cdf0dcc799b20c1ea7173e82;hb=bd368448838fb00212fa34d70e467cf4c8e12206;hp=572a00853d161b00f033dcaab438a0ee3b97baec;hpb=e55f806e5ba30a82c0c03dc1fc53f6e13fffb1bb;p=freeside.git diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index 572a00853..8c1c350fa 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -9,6 +9,8 @@ use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles $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 @@ -17,6 +19,7 @@ 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 ); @@ -75,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'; @@ -167,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) @@ -187,6 +212,22 @@ Creates a new account. To add the account to the database, see L<"insert">. 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 insert [ , OPTION => VALUE ... ] Adds this account to the database. If there is an error, returns the error, @@ -221,7 +262,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'; @@ -234,7 +279,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}) ) { @@ -463,6 +508,11 @@ 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; { @@ -682,7 +732,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; @@ -695,6 +745,10 @@ 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; @@ -844,7 +898,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 @@ -853,7 +907,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} = '*'; @@ -1189,6 +1243,72 @@ 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 @@ -1197,7 +1317,7 @@ is an error, returns the error, otherwise returns false. =cut sub decrement_seconds { - shift->_op_seconds('-', @_); + shift->_op_usage('-', 'seconds', @_); } =item increment_seconds SECONDS @@ -1208,7 +1328,7 @@ is an error, returns the error, otherwise returns false. =cut sub increment_seconds { - shift->_op_seconds('+', @_); + shift->_op_usage('+', 'seconds', @_); } @@ -1217,20 +1337,32 @@ my %op2action = ( '+' => 'unsuspend', ); my %op2condition = ( - '-' => sub { my($self, $seconds) = @_; - $self->seconds - $seconds <= 0; + '-' => sub { my($self, $column, $amount) = @_; + $self->$column - $amount <= 0; }, - '+' => sub { my($self, $seconds) = @_; - $self->seconds + $seconds > 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 ) = @_; -sub _op_seconds { - my( $self, $op, $seconds ) = @_; - warn "$me _op_seconds called for svcnum ". $self->svcnum. - ' ('. $self->email. "): $op $seconds\n" + 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'; @@ -1242,24 +1374,24 @@ sub _op_seconds { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - my $sql = "UPDATE svc_acct SET seconds = ". - " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0 + 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($seconds, $self->svcnum); + my $rv = $sth->execute($amount, $self->svcnum); die "Error executing $sql: ". $sth->errstr unless defined($rv); - die "Can't update seconds for svcnum". $self->svcnum + 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, $seconds) ) { + && &{$op2condition{$op}}($self, $column, $amount) ) { #my $error = $self->$action(); my $error = $self->cust_svc->cust_pkg->$action(); if ( $error ) { @@ -1268,6 +1400,80 @@ sub _op_seconds { } } + 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'; + + 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; @@ -1276,6 +1482,52 @@ sub _op_seconds { } +=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, @@ -1416,7 +1668,7 @@ Returns all RADIUS groups for this account (see L). sub radius_groups { my $self = shift; if ( $self->usergroup ) { - confess "specified usergroup is not an arrayref: ". $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... @@ -1525,13 +1777,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/ @@ -1705,6 +2011,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