X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2Fsvc_acct.pm;h=1e34ff03c91eaf18ea14dbf8d23207426fd25df2;hp=572a00853d161b00f033dcaab438a0ee3b97baec;hb=1748e50c012a65ecb729f15e09169f5d8122a3b1;hpb=e55f806e5ba30a82c0c03dc1fc53f6e13fffb1bb diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index 572a00853..1e34ff03c 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -8,7 +8,8 @@ use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles $username_noperiod $username_nounderscore $username_nodash $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,10 +18,13 @@ 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; @@ -61,23 +65,26 @@ $FS::UID::callback{'FS::svc_acct'} = sub { $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' , '.' , '/' ); @@ -147,6 +154,8 @@ FS::svc_Common. The following fields are currently supported: =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) @@ -167,6 +176,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) @@ -185,8 +200,195 @@ 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', + 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 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, + 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, @@ -221,7 +423,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 +440,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}) ) { @@ -290,18 +496,49 @@ sub insert { 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 { $_ !~ /^(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' @@ -309,16 +546,9 @@ sub insert { 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; @@ -427,6 +657,12 @@ sub delete { } } + my $error = $self->SUPER::delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + foreach my $radius_usergroup ( qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } ) ) { @@ -437,12 +673,6 @@ sub delete { } } - my $error = $self->SUPER::delete; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return $error; - } - $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; } @@ -463,6 +693,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 +917,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 +930,13 @@ 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') + || $self->ut_enum( '_password_encoding', + [ '', qw( plain crypt ldap ) ] + ) ; return $error if $error; @@ -726,12 +968,6 @@ sub check { unless ( $username_ampersand ) { $recref->{username} =~ /\&/ and return gettext('illegal_username'); } - if ( $password_noampersand ) { - $recref->{_password} =~ /\&/ and return gettext('illegal_password'); - } - if ( $password_noexclamation ) { - $recref->{_password} =~ /\!/ and return gettext('illegal_password'); - } unless ( $username_percent ) { $recref->{username} =~ /\%/ and return gettext('illegal_username'); } @@ -761,7 +997,7 @@ sub check { $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0]; } else { return "Illegal shell \`". $self->shell. "\'; ". - $conf->dir. "/shells contains: @shells"; + "shells configuration value contains: @shells"; } } else { $recref->{shell} = '/bin/sync'; @@ -839,36 +1075,92 @@ sub check { $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} = '!!'; + if ( $recref->{_password_encoding} eq 'ldap' ) { + + if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) { + $recref->{_password} = uc($1).$2; + } else { + return 'Illegal (ldap-encoded) password: '. $recref->{_password}; + } + + } elsif ( $recref->{_password_encoding} eq 'crypt' ) { + + if ( $recref->{_password} =~ + #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/ + /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/ + ) { + + $recref->{_password} = $1.$2; + + } else { + return 'Illegal (crypt-encoded) password'; + } + + } 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 { - #return "Illegal password"; - return gettext('illegal_password'). " $passwordmin-$passwordmax ". - FS::Msgcat::_gettext('illegal_password_characters'). - ": ". $recref->{_password}; + + #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 @@ -1126,10 +1418,13 @@ sub forget_snapshot { } -=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 { @@ -1147,6 +1442,8 @@ L). =cut +# FS::h_svc_acct has a history-aware svc_domain override + sub svc_domain { my $self = shift; $self->{'_domsvc'} @@ -1162,10 +1459,13 @@ Returns the FS::cust_svc record for this account (see L). #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 { @@ -1189,6 +1489,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 +1563,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 +1574,7 @@ is an error, returns the error, otherwise returns false. =cut sub increment_seconds { - shift->_op_seconds('+', @_); + shift->_op_usage('+', 'seconds', @_); } @@ -1217,20 +1583,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, $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, $seconds) = @_; - $self->seconds + $seconds > 0; + '+' => sub { my($self, $column, $amount) = @_; + $self->$column + $amount > 0; }, ); -sub _op_seconds { - my( $self, $op, $seconds ) = @_; - warn "$me _op_seconds called for svcnum ". $self->svcnum. - ' ('. $self->email. "): $op $seconds\n" +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'; @@ -1242,32 +1620,80 @@ 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 ( &{$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, $seconds) ) { + && &{$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; @@ -1275,6 +1701,137 @@ sub _op_seconds { } +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 @@ -1416,7 +1973,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... @@ -1471,23 +2028,42 @@ sub check_password { #self-service and pay up ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //; - #eventually should check a "password-encoding" field - 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; + 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 { - warn "Can't check password: Unrecognized encryption for svcnum ". - $self->svcnum. "\n"; - 0; + + #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; + } + } } @@ -1508,14 +2084,40 @@ database. sub crypt_password { my $self = shift; - #eventually should check a "password-encoding" field - if ( length($self->_password) == 13 - || $self->_password =~ /^\$(1|2a?)\$/ - || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/ - ) - { - $self->_password; - } else { + + 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( @@ -1525,11 +2127,133 @@ 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 { + croak "unknown encryption method $encryption"; + } + + } else { + + if ( length($self->_password) == 13 + || $self->_password =~ /^\$(1|2a?)\$/ + || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/ + ) + { + $self->_password; } else { - die "unknown encryption method $encryption"; + + #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 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 @@ -1705,6 +2429,81 @@ 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, + ($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